From 36b0a1b039d86aea9b9684db3b8edaf09a150285 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 28 Jun 2009 17:56:41 +0000 Subject: 2009-06-28 Tobias Burnus Francois-Xavier Coudert PR fortran/34112 * symbol.c (gfc_add_ext_attribute): New function. (gfc_get_sym_tree): New argument allow_subroutine. (gfc_get_symbol,gfc_get_ha_sym_tree,gen_cptr_param,gen_fptr_param gen_shape_param,generate_isocbinding_symbol): Use it. * decl.c (find_special): New argument allow_subroutine. (add_init_expr_to_sym,add_hidden_procptr_result,attr_decl1, match_procedure_in_type,gfc_match_final_decl): Use it. (gfc_match_gcc_attributes): New function. * gfortran.texi (Mixed-Language Programming): New section "GNU Fortran Compiler Directives". * gfortran.h (ext_attr_t): New struct. (symbol_attributes): Use it. (gfc_add_ext_attribute): New prototype. (gfc_get_sym_tree): Update pototype. * expr.c (gfc_check_pointer_assign): Check whether call convention is the same. * module.c (import_iso_c_binding_module, create_int_parameter, use_iso_fortran_env_module): Update gfc_get_sym_tree call. * scanner.c (skip_gcc_attribute): New function. (skip_free_comments,skip_fixed_comments): Use it. (gfc_next_char_literal): Support !GCC$ lines. * resolve.c (check_host_association): Update gfc_get_sym_tree call. * match.c (gfc_match_sym_tree,gfc_match_call): Update gfc_get_sym_tree call. * trans-decl.c (add_attributes_to_decl): New function. (gfc_get_symbol_decl,get_proc_pointer_decl, gfc_get_extern_function_decl,build_function_decl: Use it. * match.h (gfc_match_gcc_attributes): Add prototype. * parse.c (decode_gcc_attribute): New function. (next_free,next_fixed): Support !GCC$ lines. * primary.c (match_actual_arg,check_for_implicit_index, gfc_match_rvalue,gfc_match_rvalue): Update gfc_get_sym_tree call. 2009-06-28 Tobias Burnus PR fortran/34112 * gfortran.dg/compiler-directive_1.f90: New test. * gfortran.dg/compiler-directive_2.f: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149036 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9ea2a2d24d3..697c1ab5070 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4400,7 +4400,7 @@ check_host_association (gfc_expr *e) } /* Give the symbol a symtree in the right place! */ - gfc_get_sym_tree (sym->name, gfc_current_ns, &st); + gfc_get_sym_tree (sym->name, gfc_current_ns, &st, false); st->n.sym = sym; if (old_sym->attr.flavor == FL_PROCEDURE) -- cgit v1.2.1 From eee4a6d85d3a9f24b48a26fe6455807c53bad76b Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 4 Jul 2009 12:28:43 +0000 Subject: 2009-07-04 Janus Weil PR fortran/40593 * interface.c (compare_actual_formal): Take care of proc-pointer-valued functions as actual arguments. * trans-expr.c (gfc_conv_procedure_call): Ditto. * resolve.c (resolve_specific_f0): Use the correct ts. 2009-07-04 Janus Weil PR fortran/40593 * gfortran.dg/proc_ptr_result_6.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149227 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 697c1ab5070..c1069489394 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1828,7 +1828,10 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) found: gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); - expr->ts = sym->ts; + if (sym->result) + expr->ts = sym->result->ts; + else + expr->ts = sym->ts; expr->value.function.name = sym->name; expr->value.function.esym = sym; if (sym->as != NULL) -- cgit v1.2.1 From 88a37d69d9f4acebdb312422aca037999d333638 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 5 Jul 2009 19:13:59 +0000 Subject: 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.h : Change the compcall member of the 'value' union in the gfc_expr structure so that its fields overlap with the 'function' member. * resolve.c (resolve_compcall): Set the function.esym. * trans-expr.c (gfc_trans_arrayfunc_assign): Use is_proc_ptr_comp in the condition. * dependency.c (gfc_full_array_ref_p): Ensure that 'contiguous' retunrs a value if non-NULL. 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.dg/func_assign_3.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149262 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c1069489394..41ac03796bf 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4818,8 +4818,8 @@ resolve_compcall (gfc_expr* e) e->value.function.actual = newactual; e->value.function.name = e->value.compcall.name; + e->value.function.esym = target->n.sym; e->value.function.isym = NULL; - e->value.function.esym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; -- cgit v1.2.1 From ff70e44325c390560120b8ab5a8e0043d0403aef Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 9 Jul 2009 14:07:03 +0000 Subject: 2009-07-09 Janus Weil PR fortran/40646 * dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'. * expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'. (gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'. (replace_comp,gfc_expr_replace_comp): New functions, analogous to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components instead of symbols. * gfortran.h (gfc_expr_replace_comp): New prototype. (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'. * interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'. * match.c (gfc_match_pointer_assignment): Ditto. * primary.c (gfc_match_varspec): Handle array-valued procedure pointers and procedure pointer components. Renamed 'is_proc_ptr_comp'. * resolve.c (resolve_fl_derived): Correctly handle interfaces with RESULT statement, and handle array-valued procedure pointer components. (resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed 'is_proc_ptr_comp'. * trans-array.c (gfc_walk_function_expr): Ditto. * trans-decl.c (gfc_get_symbol_decl): Security check for presence of ns->proc_name. * trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure pointer components. Renamed 'is_proc_ptr_comp'. (conv_function_val,gfc_trans_arrayfunc_assign): Renamed 'is_proc_ptr_comp'. (gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead make a copy of it. * trans-io.c (gfc_trans_transfer): Handle array-valued procedure pointer components. 2009-07-09 Janus Weil PR fortran/40646 * gfortran.dg/proc_ptr_22.f90: New. * gfortran.dg/proc_ptr_comp_12.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149419 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 41ac03796bf..e3aba1a1af2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1236,7 +1236,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, continue; } - if (is_proc_ptr_comp (e, &comp)) + if (gfc_is_proc_ptr_comp (e, &comp)) { e->ts = comp->ts; e->expr_type = EXPR_VARIABLE; @@ -4834,7 +4834,7 @@ static gfc_try resolve_ppc_call (gfc_code* c) { gfc_component *comp; - gcc_assert (is_proc_ptr_comp (c->expr1, &comp)); + gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp)); c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; @@ -4862,7 +4862,7 @@ static gfc_try resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; - gcc_assert (is_proc_ptr_comp (e, &comp)); + gcc_assert (gfc_is_proc_ptr_comp (e, &comp)); /* Convert to EXPR_FUNCTION. */ e->expr_type = EXPR_FUNCTION; @@ -9034,32 +9034,40 @@ resolve_fl_derived (gfc_symbol *sym) resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) - c->ts = ifc->result->ts; - else - c->ts = ifc->ts; + { + c->ts = ifc->result->ts; + c->attr.allocatable = ifc->result->attr.allocatable; + c->attr.pointer = ifc->result->attr.pointer; + c->attr.dimension = ifc->result->attr.dimension; + c->as = gfc_copy_array_spec (ifc->result->as); + } + else + { + c->ts = ifc->ts; + c->attr.allocatable = ifc->attr.allocatable; + c->attr.pointer = ifc->attr.pointer; + c->attr.dimension = ifc->attr.dimension; + c->as = gfc_copy_array_spec (ifc->as); + } c->ts.interface = ifc; c->attr.function = ifc->attr.function; c->attr.subroutine = ifc->attr.subroutine; gfc_copy_formal_args_ppc (c, ifc); - c->attr.allocatable = ifc->attr.allocatable; - c->attr.pointer = ifc->attr.pointer; c->attr.pure = ifc->attr.pure; c->attr.elemental = ifc->attr.elemental; - c->attr.dimension = ifc->attr.dimension; c->attr.recursive = ifc->attr.recursive; c->attr.always_explicit = ifc->attr.always_explicit; - /* Copy array spec. */ - c->as = gfc_copy_array_spec (ifc->as); - /* TODO: if (c->as) + /* Replace symbols in array spec. */ + if (c->as) { int i; for (i = 0; i < c->as->rank; i++) { - gfc_expr_replace_symbols (c->as->lower[i], c); - gfc_expr_replace_symbols (c->as->upper[i], c); + gfc_expr_replace_comp (c->as->lower[i], c); + gfc_expr_replace_comp (c->as->upper[i], c); } - }*/ + } /* Copy char length. */ if (ifc->ts.cl) { -- cgit v1.2.1 From e4b33af48d863ec6f38decb87959ddc6cbdc40e1 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 9 Jul 2009 16:48:50 +0000 Subject: 2008-07-09 Paul Thomas PR fortran/40629 * resolve.c (check_host_association): Use the existing accessible symtree and treat function expressions with symbols that have procedure flavor. 2008-07-09 Paul Thomas PR fortran/40629 * gfortran.dg/host_assoc_function_9.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149422 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e3aba1a1af2..9b091ad0162 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4402,12 +4402,13 @@ check_host_association (gfc_expr *e) gfc_free (e->shape); } - /* Give the symbol a symtree in the right place! */ - gfc_get_sym_tree (sym->name, gfc_current_ns, &st, false); - st->n.sym = sym; + /* Give the expression the right symtree! */ + gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); + gcc_assert (st != NULL); - if (old_sym->attr.flavor == FL_PROCEDURE) - { + if (old_sym->attr.flavor == FL_PROCEDURE + || e->expr_type == EXPR_FUNCTION) + { /* Original was function so point to the new symbol, since the actual argument list is already attached to the expression. */ -- cgit v1.2.1 From 452a374337164f940ddae97b6e8632bf34475e7f Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 13 Jul 2009 13:41:37 +0000 Subject: 2009-07-13 Janus Weil PR fortran/40646 * module.c (mio_symbol): If the symbol has formal arguments, the formal namespace will be present. * resolve.c (resolve_actual_arglist): Correctly handle 'called' procedure pointer components as actual arguments. (resolve_fl_derived,resolve_symbol): Make sure the formal namespace is present. * trans-expr.c (gfc_conv_procedure_call): Correctly handle the formal arguments of procedure pointer components. 2009-07-13 Janus Weil PR fortran/40646 * gfortran.dg/proc_ptr_22.f90: Extended. * gfortran.dg/proc_ptr_comp_12.f90: Extended. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149586 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9b091ad0162..880dfd0e886 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1239,7 +1239,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_is_proc_ptr_comp (e, &comp)) { e->ts = comp->ts; - e->expr_type = EXPR_VARIABLE; + if (e->value.compcall.actual == NULL) + e->expr_type = EXPR_VARIABLE; + else + { + if (comp->as != NULL) + e->rank = comp->as->rank; + e->expr_type = EXPR_FUNCTION; + } goto argument_list; } @@ -8993,6 +9000,9 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } +static void resolve_symbol (gfc_symbol *sym); + + /* Resolve the components of a derived type. */ static gfc_try @@ -9031,6 +9041,9 @@ resolve_fl_derived (gfc_symbol *sym) { gfc_symbol *ifc = c->ts.interface; + if (ifc->formal && !ifc->formal_ns) + resolve_symbol (ifc); + if (ifc->attr.intrinsic) resolve_intrinsic (ifc, &ifc->declared_at); @@ -9832,6 +9845,20 @@ resolve_symbol (gfc_symbol *sym) if (sym->formal_ns && sym->formal_ns != gfc_current_ns) gfc_resolve (sym->formal_ns); + /* Make sure the formal namespace is present. */ + if (sym->formal && !sym->formal_ns) + { + gfc_formal_arglist *formal = sym->formal; + while (formal && !formal->sym) + formal = formal->next; + + if (formal) + { + sym->formal_ns = formal->sym->ns; + sym->formal_ns->refs++; + } + } + /* Check threadprivate restrictions. */ if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all && (!sym->attr.in_common -- cgit v1.2.1 From f8fc09fd01415b21febdc48bbdfcb1fad34d8041 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 15 Jul 2009 08:41:29 +0000 Subject: 2009-07-15 Janus Weil PR fortran/40743 * resolve.c (resolve_symbol): Don't resolve the formal namespace of a contained procedure. 2009-07-15 Janus Weil PR fortran/40743 * gfortran.dg/interface_assignment_4.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149662 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 880dfd0e886..5b4fc2d6949 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9842,7 +9842,8 @@ resolve_symbol (gfc_symbol *sym) formal_arg_flag = 0; /* Resolve formal namespaces. */ - if (sym->formal_ns && sym->formal_ns != gfc_current_ns) + if (sym->formal_ns && sym->formal_ns != gfc_current_ns + && !sym->attr.contained) gfc_resolve (sym->formal_ns); /* Make sure the formal namespace is present. */ -- cgit v1.2.1 From 3506b33fb392a4177653c120138be8da0b28f71a Mon Sep 17 00:00:00 2001 From: jakub Date: Thu, 23 Jul 2009 18:09:43 +0000 Subject: PR fortran/40839 * io.c (gfc_resolve_dt): Add LOC argument. Fail if dt->io_unit is NULL. Return FAILURE after issuing error about negative UNIT number. (match_io_element): Don't segfault if current_dt->io_unit is NULL. * gfortran.h (gfc_resolve_dt): Adjust prototype. * resolve.c (resolve_code): Adjust caller. * gfortran.dg/pr40839.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150021 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5b4fc2d6949..376803d69d9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7119,7 +7119,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_READ: case EXEC_WRITE: - if (gfc_resolve_dt (code->ext.dt) == FAILURE) + if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE) break; resolve_branch (code->ext.dt->err, code); -- cgit v1.2.1 From 5d50997a4873b2ff4acdfe03f24b81d7ada048fd Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 24 Jul 2009 11:00:01 +0000 Subject: 2009-07-24 Janus Weil PR fortran/40822 * array.c (gfc_resolve_character_array_constructor): Use new function gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (gfc_simplify_expr): Ditto. * gfortran.h (gfc_new_charlen): New prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Use new function gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen,resolve_fl_derived, resolve_symbol): Ditto. * symbol.c (gfc_new_charlen): New function to create a new gfc_charlen structure and add it to a namespace. (gfc_copy_formal_args_intr): Make sure ts.cl is present for CHARACTER variables. 2009-07-24 Janus Weil PR fortran/40822 * gfortran.dg/char_length_16.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150047 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 32 +++++--------------------------- 1 file changed, 5 insertions(+), 27 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 376803d69d9..e09167b1be2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4012,11 +4012,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) e->ts.kind = gfc_default_character_kind; if (!e->ts.cl) - { - e->ts.cl = gfc_get_charlen (); - e->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = e->ts.cl; - } + e->ts.cl = gfc_new_charlen (gfc_current_ns); if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); @@ -4489,9 +4485,7 @@ gfc_resolve_character_operator (gfc_expr *e) else if (op2->expr_type == EXPR_CONSTANT) e2 = gfc_int_expr (op2->value.character.length); - e->ts.cl = gfc_get_charlen (); - e->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = e->ts.cl; + e->ts.cl = gfc_new_charlen (gfc_current_ns); if (!e1 || !e2) return; @@ -4530,11 +4524,7 @@ fixup_charlen (gfc_expr *e) default: if (!e->ts.cl) - { - e->ts.cl = gfc_get_charlen (); - e->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = e->ts.cl; - } + e->ts.cl = gfc_new_charlen (gfc_current_ns); break; } @@ -9085,16 +9075,10 @@ resolve_fl_derived (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.cl) { - c->ts.cl = gfc_get_charlen(); + c->ts.cl = gfc_new_charlen (sym->ns); c->ts.cl->resolved = ifc->ts.cl->resolved; c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length); /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/ - /* Add charlen to namespace. */ - /*if (c->formal_ns) - { - c->ts.cl->next = c->formal_ns->cl_list; - c->formal_ns->cl_list = c->ts.cl; - }*/ } } else if (c->ts.interface->name[0] != '\0') @@ -9490,16 +9474,10 @@ resolve_symbol (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.cl) { - sym->ts.cl = gfc_get_charlen(); + sym->ts.cl = gfc_new_charlen (sym->ns); sym->ts.cl->resolved = ifc->ts.cl->resolved; sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length); gfc_expr_replace_symbols (sym->ts.cl->length, sym); - /* Add charlen to namespace. */ - if (sym->formal_ns) - { - sym->ts.cl->next = sym->formal_ns->cl_list; - sym->formal_ns->cl_list = sym->ts.cl; - } } } else if (sym->ts.interface->name[0] != '\0') -- cgit v1.2.1 From fe9b08a2c2202c07f1f02f83e8dfac36923b6662 Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 25 Jul 2009 11:56:35 +0000 Subject: 2009-07-25 Janus Weil PR fortran/39630 * decl.c (match_ppc_decl): Implement the PASS attribute for procedure pointer components. (match_binding_attributes): Ditto. * gfortran.h (gfc_component): Add member 'tb'. (gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const. * module.c (MOD_VERSION): Bump module version. (binding_ppc): New string constants. (mio_component): Only use formal args if component is a procedure pointer and add 'tb' member. (mio_typebound_proc): Include pass_arg and take care of procedure pointer components. * resolve.c (update_arglist_pass): Add argument 'name' and take care of optional arguments. (extract_ppc_passed_object): New function, analogous to extract_compcall_passed_object, but for procedure pointer components. (update_ppc_arglist): New function, analogous to update_compcall_arglist, but for procedure pointer components. (resolve_typebound_generic_call): Added argument to update_arglist_pass. (resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute. (resolve_fl_derived): Check the PASS argument for procedure pointer components. * symbol.c (verify_bind_c_derived_type): Reject procedure pointer components in BIND(C) types. 2009-07-25 Janus Weil PR fortran/39630 * gfortran.dg/proc_ptr_comp_3.f90: Modified. * gfortran.dg/proc_ptr_comp_pass_1.f90: New. * gfortran.dg/proc_ptr_comp_pass_2.f90: New. * gfortran.dg/proc_ptr_comp_pass_3.f90: New. * gfortran.dg/proc_ptr_comp_pass_4.f90: New. * gfortran.dg/proc_ptr_comp_pass_5.f90: New. * gfortran.dg/typebound_call_10.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150078 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 191 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 183 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e09167b1be2..aaab554d4de 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4535,7 +4535,8 @@ fixup_charlen (gfc_expr *e) procedures at the right position. */ static gfc_actual_arglist* -update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos) +update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, + const char *name) { gcc_assert (argpos > 0); @@ -4546,14 +4547,16 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos) result = gfc_get_actual_arglist (); result->expr = po; result->next = lst; + if (name) + result->name = name; return result; } - gcc_assert (lst); - gcc_assert (argpos > 1); - - lst->next = update_arglist_pass (lst->next, po, argpos - 1); + if (lst) + lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); + else + lst = update_arglist_pass (NULL, po, argpos - 1, name); return lst; } @@ -4611,7 +4614,74 @@ update_compcall_arglist (gfc_expr* e) gcc_assert (tbp->pass_arg_num > 0); e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, - tbp->pass_arg_num); + tbp->pass_arg_num, + tbp->pass_arg); + + return SUCCESS; +} + + +/* Extract the passed object from a PPC call (a copy of it). */ + +static gfc_expr* +extract_ppc_passed_object (gfc_expr *e) +{ + gfc_expr *po; + gfc_ref **ref; + + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + + /* Remove PPC reference. */ + ref = &po->ref; + while ((*ref)->next) + (*ref) = (*ref)->next; + gfc_free_ref_list (*ref); + *ref = NULL; + + if (gfc_resolve_expr (po) == FAILURE) + return NULL; + + return po; +} + + +/* Update the actual arglist of a procedure pointer component to include the + passed-object. */ + +static gfc_try +update_ppc_arglist (gfc_expr* e) +{ + gfc_expr* po; + gfc_component *ppc; + gfc_typebound_proc* tb; + + if (!gfc_is_proc_ptr_comp (e, &ppc)) + return FAILURE; + + tb = ppc->tb; + + if (tb->error) + return FAILURE; + else if (tb->nopass) + return SUCCESS; + + po = extract_ppc_passed_object (e); + if (!po) + return FAILURE; + + if (po->rank > 0) + { + gfc_error ("Passed-object at %L must be scalar", &e->where); + return FAILURE; + } + + gcc_assert (tb->pass_arg_num > 0); + e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, + tb->pass_arg_num, + tb->pass_arg); return SUCCESS; } @@ -4714,7 +4784,8 @@ resolve_typebound_generic_call (gfc_expr* e) gcc_assert (g->specific->pass_arg_num > 0); gcc_assert (!g->specific->error); - args = update_arglist_pass (args, po, g->specific->pass_arg_num); + args = update_arglist_pass (args, po, g->specific->pass_arg_num, + g->specific->pass_arg); } resolve_actual_arglist (args, target->attr.proc, is_external_proc (target) && !target->formal); @@ -4836,7 +4907,6 @@ resolve_ppc_call (gfc_code* c) c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; - c->ext.actual = c->expr1->value.compcall.actual; if (!comp->attr.subroutine) gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); @@ -4844,6 +4914,11 @@ resolve_ppc_call (gfc_code* c) if (resolve_ref (c->expr1) == FAILURE) return FAILURE; + if (update_ppc_arglist (c->expr1) == FAILURE) + return FAILURE; + + c->ext.actual = c->expr1->value.compcall.actual; + if (resolve_actual_arglist (c->ext.actual, comp->attr.proc, comp->formal == NULL) == FAILURE) return FAILURE; @@ -4880,6 +4955,9 @@ resolve_expr_ppc (gfc_expr* e) comp->formal == NULL) == FAILURE) return FAILURE; + if (update_ppc_arglist (e) == FAILURE) + return FAILURE; + gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); return SUCCESS; @@ -9095,6 +9173,103 @@ resolve_fl_derived (gfc_symbol *sym) c->attr.implicit_type = 1; } + /* Procedure pointer components: Check PASS arg. */ + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0) + { + gfc_symbol* me_arg; + + if (c->tb->pass_arg) + { + gfc_formal_arglist* i; + + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ + + me_arg = NULL; + c->tb->pass_arg_num = 1; + for (i = c->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, c->tb->pass_arg)) + { + me_arg = i->sym; + break; + } + c->tb->pass_arg_num++; + } + + if (!me_arg) + { + gfc_error ("Procedure pointer component '%s' with PASS(%s) " + "at %L has no argument '%s'", c->name, + c->tb->pass_arg, &c->loc, c->tb->pass_arg); + c->tb->error = 1; + return FAILURE; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + c->tb->pass_arg_num = 1; + if (!c->formal) + { + gfc_error ("Procedure pointer component '%s' with PASS at %L " + "must have at least one argument", + c->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + me_arg = c->formal->sym; + } + + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + if (me_arg->ts.type != BT_DERIVED + || me_arg->ts.derived != sym) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" + " the derived type '%s'", me_arg->name, c->name, + me_arg->name, &c->loc, sym->name); + c->tb->error = 1; + return FAILURE; + } + + /* Check for C453. */ + if (me_arg->attr.dimension) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "must be scalar", me_arg->name, c->name, me_arg->name, + &c->loc); + c->tb->error = 1; + return FAILURE; + } + + if (me_arg->attr.pointer) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "may not have the POINTER attribute", me_arg->name, + c->name, me_arg->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + + if (me_arg->attr.allocatable) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "may not be ALLOCATABLE", me_arg->name, c->name, + me_arg->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + + /* TODO: Make this an error once CLASS is implemented. */ + if (!sym->attr.sequence) + gfc_warning ("Polymorphic entities are not yet implemented," + " non-polymorphic passed-object dummy argument of '%s'" + " at %L accepted", c->name, &c->loc); + + } + /* Check type-spec if this is not the parent-type component. */ if ((!sym->attr.extension || c != sym->components) && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) -- cgit v1.2.1 From c49db15efe1d8b2571d0c2b180338ecce415bff0 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 27 Jul 2009 09:32:20 +0000 Subject: 2009-07-26 Tobias Burnus PR fortran/40851 * resolve.c (resolve_symbol): Do not initialize pointer * derived-types. * trans-decl.c (init_intent_out_dt): Ditto. (generate_local_decl): No need to set attr.referenced for DT pointers. 2009-07-26 Tobias Burnus PR fortran/40851 * gfortran.dg/derived_init_3.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150108 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index aaab554d4de..053ec839a08 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10036,7 +10036,7 @@ resolve_symbol (gfc_symbol *sym) if ((!a->save && !a->dummy && !a->pointer && !a->in_common && !a->use_assoc && !(a->function && sym != sym->result)) - || (a->dummy && a->intent == INTENT_OUT)) + || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) apply_default_init (sym); } -- cgit v1.2.1 From 7ea64434b40d07d43f4aa6cafac4684487e69304 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 1 Aug 2009 13:45:12 +0000 Subject: 2009-08-01 Paul Thomas PR fortran/40011 * error.c : Add static flag 'warnings_not_errors'. (gfc_error): If 'warnings_not_errors' is set, branch to code from gfc_warning. (gfc_clear_error): Reset 'warnings_not_errors'. (gfc_errors_to_warnings): New function. * options.c (gfc_post_options): If pedantic and flag_whole_file change the latter to a value of 2. * parse.c (parse_module): Add module namespace to gsymbol. (resolve_all_program_units): New function. (clean_up_modules): New function. (translate_all_program_units): New function. (gfc_parse_file): If whole_file, do not clean up module right away and add derived types to namespace derived types. In addition, call the three new functions above. * resolve.c (not_in_recursive): New function. (not_entry_self_reference): New function. (resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN, procedure must not be in the course of being resolved and must return false for the two new functions. Pack away the current derived type list before calling gfc_resolve for the gsymbol namespace. It is unconditionally an error if the ranks of the reference and ther procedure do not match. Convert errors to warnings during call to gfc_procedure_use if not pedantic or legacy. (gfc_resolve): Set namespace resolved flag to -1 during resolution and store current cs_base. * trans-decl.c (gfc_get_symbol_decl): If whole_file compilation substitute a use associated variable, if it is available in a gsymbolnamespace. (gfc_get_extern_function_decl): If the procedure is use assoc, do not attempt to find it in a gsymbol because it could be an interface. If the symbol exists in a module namespace, return its backend_decl. * trans-expr.c (gfc_trans_scalar_assign): If a derived type assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs. * trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a boolean argument. Copy component backend_decls directly if the components are derived types and from_gsym is true. (gfc_get_derived_type): If whole_file copy the derived type from the module if it is use associated, otherwise, if can be found in another gsymbol namespace, use the existing derived type as the TYPE_CANONICAL and build normally. * gfortran.h : Add derived_types and resolved fields to gfc_namespace. Include prototype for gfc_errors_to_warnings. 2009-08-01 Paul Thomas PR fortran/40011 * gfortran.dg/whole_file_7.f90: New test. * gfortran.dg/whole_file_8.f90: New test. * gfortran.dg/whole_file_9.f90: New test. * gfortran.dg/whole_file_10.f90: New test. * gfortran.dg/whole_file_11.f90: New test. * gfortran.dg/whole_file_12.f90: New test. * gfortran.dg/whole_file_13.f90: New test. * gfortran.dg/whole_file_14.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150333 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 85 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 83 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 053ec839a08..6202a2d197e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1652,6 +1652,47 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual) The namespace of the gsymbol is resolved and then, once this is done the interface is checked. */ + +static bool +not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (!gsym_ns->proc_name->attr.recursive) + return true; + + if (sym->ns == gsym_ns) + return false; + + if (sym->ns->parent && sym->ns->parent == gsym_ns) + return false; + + return true; +} + +static bool +not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (gsym_ns->entries) + { + gfc_entry_list *entry = gsym_ns->entries; + + for (; entry; entry = entry->next) + { + if (strcmp (sym->name, entry->sym->name) == 0) + { + if (strcmp (gsym_ns->proc_name->name, + sym->ns->proc_name->name) == 0) + return false; + + if (sym->ns->parent + && strcmp (gsym_ns->proc_name->name, + sym->ns->parent->proc_name->name) == 0) + return false; + } + } + } + return true; +} + static void resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_actual_arglist **actual, int sub) @@ -1668,9 +1709,13 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_global_used (gsym, where); if (gfc_option.flag_whole_file + && sym->attr.if_source == IFSRC_UNKNOWN && gsym->type != GSYM_UNKNOWN && gsym->ns - && gsym->ns->proc_name) + && gsym->ns->resolved != -1 + && gsym->ns->proc_name + && not_in_recursive (sym, gsym->ns) + && not_entry_self_reference (sym, gsym->ns)) { /* Make sure that translation for the gsymbol occurs before the procedure currently being resolved. */ @@ -1687,9 +1732,41 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } if (!gsym->ns->resolved) - gfc_resolve (gsym->ns); + { + gfc_dt_list *old_dt_list; + + /* Stash away derived types so that the backend_decls do not + get mixed up. */ + old_dt_list = gfc_derived_types; + gfc_derived_types = NULL; + + gfc_resolve (gsym->ns); + + /* Store the new derived types with the global namespace. */ + if (gfc_derived_types) + gsym->ns->derived_types = gfc_derived_types; + + /* Restore the derived types of this namespace. */ + gfc_derived_types = old_dt_list; + } + + if (gsym->ns->proc_name->attr.function + && gsym->ns->proc_name->as + && gsym->ns->proc_name->as->rank + && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + if (gfc_option.flag_whole_file == 1 + || ((gfc_option.warn_std & GFC_STD_LEGACY) + && + !(gfc_option.warn_std & GFC_STD_GNU))) + gfc_errors_to_warnings (1); gfc_procedure_use (gsym->ns->proc_name, actual, where); + + gfc_errors_to_warnings (0); } if (gsym->type == GSYM_UNKNOWN) @@ -11134,15 +11211,19 @@ void gfc_resolve (gfc_namespace *ns) { gfc_namespace *old_ns; + code_stack *old_cs_base; if (ns->resolved) return; + ns->resolved = -1; old_ns = gfc_current_ns; + old_cs_base = cs_base; resolve_types (ns); resolve_codes (ns); gfc_current_ns = old_ns; + cs_base = old_cs_base; ns->resolved = 1; } -- cgit v1.2.1 From 8e9b41f0df3bc3b29b8cd53bfb4c56cfb8f98700 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 2 Aug 2009 10:58:44 +0000 Subject: 2009-08-02 Janus Weil PR fortran/40881 * decl.c (match_char_length): Warn about old-style character length declarations. * match.c (match_arithmetic_if,gfc_match_if): Modify warning message for arithmetic if. (gfc_match_goto): Warn about computed gotos. (gfc_match_return): Warn about alternate return. (gfc_match_st_function): Warn about statement functions. * resolve.c (resolve_fl_procedure): Modify warning message for assumed-length character functions. 2009-08-02 Janus Weil PR fortran/40881 * gfortran.dg/aliasing_dummy_1.f90: Add -std=legacy. * gfortran.dg/altreturn_3.f90: Ditto. * gfortran.dg/altreturn_5.f90: Ditto. * gfortran.dg/altreturn_6.f90: Ditto. * gfortran.dg/altreturn_7.f90: Ditto. * gfortran.dg/array_constructor_13.f90: Ditto. * gfortran.dg/arrayio_7.f90: Ditto. * gfortran.dg/arrayio_8.f90: Ditto. * gfortran.dg/assumed_charlen_function_3.f90: Modified warning message. * gfortran.dg/assumed_charlen_function_4.f90: Add -std=legacy. * gfortran.dg/assumed_charlen_function_5.f90: Modified warning message. * gfortran.dg/backspace_8.f: Add -std=legacy. * gfortran.dg/backspace_9.f: Ditto. * gfortran.dg/char_comparison_1.f: Ditto. * gfortran.dg/char_decl_1.f90: Ditto. * gfortran.dg/char_initialiser_actual.f90: Ditto. * gfortran.dg/char_pointer_assign.f90: Ditto. * gfortran.dg/char_pointer_dependency.f90: Ditto. * gfortran.dg/char_pointer_dummy.f90: Ditto. * gfortran.dg/char_pointer_func.f90: Ditto. * gfortran.dg/common_8.f90: Ditto. * gfortran.dg/constant_substring.f: Ditto. * gfortran.dg/data_char_2.f90: Ditto. * gfortran.dg/der_array_io_1.f90: Ditto. * gfortran.dg/der_array_io_2.f90: Ditto. * gfortran.dg/der_array_io_3.f90: Ditto. * gfortran.dg/der_io_3.f90: Ditto. * gfortran.dg/dev_null.F90: Ditto. * gfortran.dg/direct_io_2.f90: Ditto. * gfortran.dg/do_iterator_2.f90: Ditto. * gfortran.dg/e_d_fmt.f90: Ditto. * gfortran.dg/empty_format_1.f90: Ditto. * gfortran.dg/entry_17.f90: Modified warning message. * gfortran.dg/entry_7.f90: Add -std=legacy. * gfortran.dg/eor_1.f90: Ditto. * gfortran.dg/equiv_2.f90: Ditto. * gfortran.dg/equiv_constraint_2.f90: Use new-style character length. * gfortran.dg/equiv_substr.f90: Add -std=legacy. * gfortran.dg/extended_char_comparison_1.f: Ditto. * gfortran.dg/fmt_bz_bn_err.f: Ditto. * gfortran.dg/fmt_error_2.f90: Ditto. * gfortran.dg/fmt_read_bz_bn.f90: Ditto. * gfortran.dg/fmt_tl.f: Ditto. * gfortran.dg/fmt_white.f: Ditto. * gfortran.dg/func_derived_1.f90: Ditto. * gfortran.dg/g77_intrinsics_funcs.f: Ditto. * gfortran.dg/g77_intrinsics_sub.f: Ditto. * gfortran.dg/global_references_2.f90: Ditto. * gfortran.dg/hollerith_1.f90: Ditto. * gfortran.dg/hollerith.f90: Use new-style character length. * gfortran.dg/hollerith_f95.f90: Ditto. * gfortran.dg/ichar_1.f90: Add -std=legacy. * gfortran.dg/implicit_6.f90: Ditto. * gfortran.dg/implicit_9.f90: Ditto. * gfortran.dg/inquire_13.f90: Ditto. * gfortran.dg/inquire_5.f90: Ditto. * gfortran.dg/inquire_6.f90: Ditto. * gfortran.dg/inquire.f90: Ditto. * gfortran.dg/io_constraints_1.f90: Use new-style character length. * gfortran.dg/io_constraints_2.f90: Ditto. * gfortran.dg/list_read_2.f90: Add -std=legacy. * gfortran.dg/loc_2.f90: Ditto. * gfortran.dg/logical_1.f90: Ditto. * gfortran.dg/longline.f: Ditto. * gfortran.dg/merge_char_1.f90: Ditto. * gfortran.dg/namelist_12.f: Ditto. * gfortran.dg/namelist_14.f90: Ditto. * gfortran.dg/namelist_18.f90: Ditto. * gfortran.dg/namelist_19.f90: Ditto. * gfortran.dg/namelist_21.f90: Ditto. * gfortran.dg/namelist_22.f90: Ditto. * gfortran.dg/namelist_37.f90: Ditto. * gfortran.dg/namelist_54.f90: Ditto. * gfortran.dg/namelist_55.f90: Ditto. * gfortran.dg/namelist_empty.f90: Ditto. * gfortran.dg/namelist_use.f90: Use new-style character length. * gfortran.dg/namelist_use_only.f90: Add -std=legacy. * gfortran.dg/nested_modules_4.f90: Ditto. * gfortran.dg/nested_modules_5.f90: Ditto. * gfortran.dg/open-options-blanks.f: Ditto. * gfortran.dg/output_exponents_1.f90: Ditto. * gfortran.dg/parens_5.f90: Ditto. * gfortran.dg/parens_6.f90: Ditto. * gfortran.dg/parent_result_ref_2.f90: Modified warning message. * gfortran.dg/pointer_function_actual_1.f90: Add -std=legacy. * gfortran.dg/pr15129.f90: Ditto. * gfortran.dg/pr15332.f: Ditto. * gfortran.dg/pr16597.f90: Ditto. * gfortran.dg/pr17143.f90: Ditto. * gfortran.dg/pr17164.f90: Ditto. * gfortran.dg/pr17229.f: Modified warning message. * gfortran.dg/pr18210.f90: Add -std=legacy. * gfortran.dg/pr19155.f: Ditto. * gfortran.dg/pr20086.f90: Ditto. * gfortran.dg/pr20124.f90: Ditto. * gfortran.dg/pr20755.f: Ditto. * gfortran.dg/pr20865.f90: Ditto. * gfortran.dg/pr20950.f: Ditto. * gfortran.dg/pr21730.f: Ditto. * gfortran.dg/pr22491.f: Ditto. * gfortran.dg/pr29713.f90: Ditto. * gfortran.dg/print_parentheses_1.f: Ditto. * gfortran.dg/print_parentheses_2.f90: Ditto. * gfortran.dg/proc_assign_1.f90: Ditto. * gfortran.dg/proc_decl_1.f90: Ditto. * gfortran.dg/proc_ptr_17.f90: Add dg-warning. * gfortran.dg/read_eor.f90: : Add -std=legacy. * gfortran.dg/read_float_1.f90: Ditto. * gfortran.dg/read_logical.f90: Ditto. * gfortran.dg/recursive_statement_functions.f90: Ditto. * gfortran.dg/return_1.f90: Ditto. * gfortran.dg/rewind_1.f90: Ditto. * gfortran.dg/runtime_warning_1.f90: Use new-style character length. * gfortran.dg/scalar_return_1.f90: Add -std=legacy. * gfortran.dg/stfunc_1.f90: Ditto. * gfortran.dg/stfunc_3.f90: Ditto. * gfortran.dg/stfunc_4.f90: Ditto. * gfortran.dg/stfunc_6.f90: Ditto. * gfortran.dg/streamio_2.f90: Ditto. * gfortran.dg/string_ctor_1.f90: Ditto. * gfortran.dg/string_null_compare_1.f: Ditto. * gfortran.dg/substr_6.f90: Ditto. * gfortran.dg/tl_editing.f90: Ditto. * gfortran.dg/unf_io_convert_1.f90: Use new-style character length. * gfortran.dg/warnings_are_errors_1.f90: Modified warning message. * gfortran.dg/x_slash_1.f: Add -std=legacy. * gfortran.dg/g77/1832.f: Ditto. * gfortran.dg/g77/19981216-0.f Ditto. * gfortran.dg/g77/19990525-0.f: Ditto. * gfortran.dg/g77/19990826-2.f: Ditto. * gfortran.dg/g77/20000630-2.f: Ditto. * gfortran.dg/g77/20010116.f: Ditto. * gfortran.dg/g77/20010519-1.f: Use new-style character length. * gfortran.dg/g77/980419-2.f: Add -std=legacy. * gfortran.dg/g77/980520-1.f: Ditto. * gfortran.dg/g77/check0.f: Ditto. * gfortran.dg/g77/cpp3.F: Ditto. * gfortran.dg/g77/cpp4.F: Use new-style character length. * gfortran.dg/g77/f77-edit-i-in.f: Add -std=legacy. * gfortran.dg/g77/f77-edit-t-in.f: Ditto. * gfortran.dg/g77/short.f: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150349 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6202a2d197e..14a111e3ad7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8289,8 +8289,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) /* Appendix B.2 of the standard. Contained functions give an error anyway. Fixed-form is likely to be F77/legacy. */ if (!sym->attr.contained && gfc_current_form != FORM_FIXED) - gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function " - "'%s' at %L is obsolescent in fortran 95", + gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + "CHARACTER(*) function '%s' at %L", sym->name, &sym->declared_at); } -- cgit v1.2.1 From de0c4488fdfa38f2c6c01b098b416b8772572e54 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 9 Aug 2009 08:35:36 +0000 Subject: 2009-08-05 Tobias Burnus PR fortran/40955 * gfortran.h (ext_attr_id_t): Add typedef for this enum. (gfc_add_ext_attribute): Use it. * decl.c (gfc_match_gcc_attributes): Ditto. * expr.c (gfc_check_pointer_assign): Ditto. * symbol.c (gfc_add_ext_attribute): Ditto. (gfc_copy_attr): Copy also ext_attr. * resolve.c (resolve_fl_derived,resolve_symbol): Ditto. * module.c (mio_symbol_attribute): Save ext_attr in the mod * file. 2009-08-05 Tobias Burnus PR fortran/40955 * gfortran.dg/module_md5_1.f90: Update MD5 check sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150589 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 14a111e3ad7..39f3cdca056 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9217,6 +9217,7 @@ resolve_fl_derived (gfc_symbol *sym) c->attr.elemental = ifc->attr.elemental; c->attr.recursive = ifc->attr.recursive; c->attr.always_explicit = ifc->attr.always_explicit; + c->attr.ext_attr |= ifc->attr.ext_attr; /* Replace symbols in array spec. */ if (c->as) { @@ -9712,6 +9713,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.dimension = ifc->attr.dimension; sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; + sym->attr.ext_attr |= ifc->attr.ext_attr; /* Copy array spec. */ sym->as = gfc_copy_array_spec (ifc->as); if (sym->as) -- cgit v1.2.1 From 8ca7f89ce738994bbb0a78ca04a7d9a984456d03 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 10 Aug 2009 09:19:24 +0000 Subject: 2009-08-10 Janus Weil PR fortran/40940 * decl.c (gfc_match_type_spec): Match CLASS statement and warn about missing polymorphism. * gfortran.h (gfc_typespec): Add field 'is_class'. * misc.c (gfc_clear_ts): Initialize 'is_class' to zero. * resolve.c (type_is_extensible): New function to check if a derived type is extensible. (resolve_fl_variable_derived): Add error checks for CLASS variables. (resolve_typebound_procedure): Disallow non-polymorphic passed-object dummy arguments, turning warning into error. (resolve_fl_derived): Use 'type_is_extensible'. Disallow non-polymorphic passed-object dummy arguments for procedure pointer components, turning warning into error. Add error check for CLASS components. 2009-08-10 Janus Weil PR fortran/40940 * gfortran.dg/class_1.f03: New. * gfortran.dg/class_2.f03: New. * gfortran.dg/proc_ptr_comp_pass_1.f90: Use CLASS instead of TYPE. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150620 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 56 ++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 47 insertions(+), 9 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 39f3cdca056..81c8ccd8b24 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7916,6 +7916,15 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } +/* Check if a derived type is extensible. */ + +static bool +type_is_extensible (gfc_symbol *sym) +{ + return !(sym->attr.is_bind_c || sym->attr.sequence); +} + + /* Additional checks for symbols with flavor variable and derived type. To be called from resolve_fl_variable. */ @@ -7964,6 +7973,25 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) return FAILURE; } + if (sym->ts.is_class) + { + /* C502. */ + if (!type_is_extensible (sym->ts.derived)) + { + gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", + sym->ts.derived->name, sym->name, &sym->declared_at); + return FAILURE; + } + + /* C509. */ + if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer)) + { + gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " + "or pointer", sym->name, &sym->declared_at); + return FAILURE; + } + } + /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) && (!no_init_flag || sym->attr.intent == INTENT_OUT)) @@ -9000,9 +9028,12 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - gfc_warning ("Polymorphic entities are not yet implemented," - " non-polymorphic passed-object dummy argument of '%s'" - " at %L accepted", proc->name, &where); + if (!me_arg->ts.is_class) + { + gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + " at %L", proc->name, &where); + goto error; + } } /* If we are extending some type, check that we don't override a procedure @@ -9164,7 +9195,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence)) + if (sym->attr.abstract && !type_is_extensible (sym)) { gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT", sym->name, &sym->declared_at); @@ -9340,11 +9371,9 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - /* TODO: Make this an error once CLASS is implemented. */ - if (!sym->attr.sequence) - gfc_warning ("Polymorphic entities are not yet implemented," - " non-polymorphic passed-object dummy argument of '%s'" - " at %L accepted", c->name, &c->loc); + if (type_is_extensible (sym) && !me_arg->ts.is_class) + gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + " at %L", c->name, &c->loc); } @@ -9412,6 +9441,15 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + /* C437. */ + if (c->ts.type == BT_DERIVED && c->ts.is_class + && !(c->attr.pointer || c->attr.allocatable)) + { + gfc_error ("Component '%s' with CLASS at %L must be allocatable " + "or pointer", c->name, &c->loc); + return FAILURE; + } + /* Ensure that all the derived type components are put on the derived type list; even in formal namespaces, where derived type pointer components might not have been declared. */ -- cgit v1.2.1 From a36eb9ee1253552fcabdb8a9c578e0b68652f126 Mon Sep 17 00:00:00 2001 From: domob Date: Mon, 10 Aug 2009 10:51:46 +0000 Subject: 2009-08-10 Daniel Kraft PR fortran/37425 * gfortran.dg/typebound_operator_1.f03: New test. * gfortran.dg/typebound_operator_2.f03: New test. 2009-08-10 Daniel Kraft PR fortran/37425 * gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op. (gfc_find_typebound_user_op): New routine. (gfc_find_typebound_intrinsic_op): Ditto. (gfc_check_operator_interface): Now public routine. * decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=). * interface.c (check_operator_interface): Made public, renamed to `gfc_check_operator_interface' accordingly and hand in the interface as gfc_symbol rather than gfc_interface so it is useful for type-bound operators, too. Return boolean result. (gfc_check_interfaces): Adapt call to `check_operator_interface'. * symbol.c (gfc_get_namespace): Initialize new field `tb_op'. (gfc_free_namespace): Free `tb_uop_root'-based tree. (find_typebound_proc_uop): New helper function. (gfc_find_typebound_proc): Use it. (gfc_find_typebound_user_op): New method. (gfc_find_typebound_intrinsic_op): Ditto. * resolve.c (resolve_tb_generic_targets): New helper function. (resolve_typebound_generic): Use it. (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New. (resolve_typebound_procedures): Resolve operators, too. (check_uop_procedure): New, code from gfc_resolve_uops. (gfc_resolve_uops): Moved main code to new `check_uop_procedure'. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150622 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 339 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 258 insertions(+), 81 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 81c8ccd8b24..5c4370427d8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8793,37 +8793,27 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } -/* Resolve a GENERIC procedure binding for a derived type. */ +/* Worker function for resolving a generic procedure binding; this is used to + resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures. + + The difference between those cases is finding possible inherited bindings + that are overridden, as one has to look for them in tb_sym_root, + tb_uop_root or tb_op, respectively. Thus the caller must already find + the super-type and set p->overridden correctly. */ static gfc_try -resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) +resolve_tb_generic_targets (gfc_symbol* super_type, + gfc_typebound_proc* p, const char* name) { gfc_tbp_generic* target; gfc_symtree* first_target; - gfc_symbol* super_type; gfc_symtree* inherited; - locus where; - - gcc_assert (st->n.tb); - gcc_assert (st->n.tb->is_generic); - - where = st->n.tb->where; - super_type = gfc_get_derived_super_type (derived); - - /* Find the overridden binding if any. */ - st->n.tb->overridden = NULL; - if (super_type) - { - gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); - if (overridden && overridden->n.tb) - st->n.tb->overridden = overridden->n.tb; - } + gcc_assert (p && p->is_generic); /* Try to find the specific bindings for the symtrees in our target-list. */ - gcc_assert (st->n.tb->u.generic); - for (target = st->n.tb->u.generic; target; target = target->next) + gcc_assert (p->u.generic); + for (target = p->u.generic; target; target = target->next) if (!target->specific) { gfc_typebound_proc* overridden_tbp; @@ -8854,7 +8844,7 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) } gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'" - " at %L", target_name, st->name, &where); + " at %L", target_name, name, &p->where); return FAILURE; /* Once we've found the specific binding, check it is not ambiguous with @@ -8866,19 +8856,19 @@ specific_found: if (target->specific->is_generic) { gfc_error ("GENERIC '%s' at %L must target a specific binding," - " '%s' is GENERIC, too", st->name, &where, target_name); + " '%s' is GENERIC, too", name, &p->where, target_name); return FAILURE; } /* Check those already resolved on this type directly. */ - for (g = st->n.tb->u.generic; g; g = g->next) + for (g = p->u.generic; g; g = g->next) if (g != target && g->specific - && check_generic_tbp_ambiguity (target, g, st->name, where) + && check_generic_tbp_ambiguity (target, g, name, p->where) == FAILURE) return FAILURE; /* Check for ambiguity with inherited specific targets. */ - for (overridden_tbp = st->n.tb->overridden; overridden_tbp; + for (overridden_tbp = p->overridden; overridden_tbp; overridden_tbp = overridden_tbp->overridden) if (overridden_tbp->is_generic) { @@ -8886,36 +8876,167 @@ specific_found: { gcc_assert (g->specific); if (check_generic_tbp_ambiguity (target, g, - st->name, where) == FAILURE) + name, p->where) == FAILURE) return FAILURE; } } } /* If we attempt to "overwrite" a specific binding, this is an error. */ - if (st->n.tb->overridden && !st->n.tb->overridden->is_generic) + if (p->overridden && !p->overridden->is_generic) { gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with" - " the same name", st->name, &where); + " the same name", name, &p->where); return FAILURE; } /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as all must have the same attributes here. */ - first_target = st->n.tb->u.generic->specific->u.specific; + first_target = p->u.generic->specific->u.specific; gcc_assert (first_target); - st->n.tb->subroutine = first_target->n.sym->attr.subroutine; - st->n.tb->function = first_target->n.sym->attr.function; + p->subroutine = first_target->n.sym->attr.subroutine; + p->function = first_target->n.sym->attr.function; return SUCCESS; } -/* Resolve the type-bound procedures for a derived type. */ +/* Resolve a GENERIC procedure binding for a derived type. */ + +static gfc_try +resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) +{ + gfc_symbol* super_type; + + /* Find the overridden binding if any. */ + st->n.tb->overridden = NULL; + super_type = gfc_get_derived_super_type (derived); + if (super_type) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); + + if (overridden && overridden->n.tb) + st->n.tb->overridden = overridden->n.tb; + } + + /* Resolve using worker function. */ + return resolve_tb_generic_targets (super_type, st->n.tb, st->name); +} + + +/* Resolve a type-bound intrinsic operator. */ + +static gfc_try +resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, + gfc_typebound_proc* p) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + /* If there's already an error here, do nothing (but don't fail again). */ + if (p->error) + return SUCCESS; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (p->is_generic); + + /* Look for an overridden binding. */ + super_type = gfc_get_derived_super_type (derived); + if (super_type && super_type->f2k_derived) + p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, + op, true); + else + p->overridden = NULL; + + /* Resolve general GENERIC properties using worker function. */ + if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE) + goto error; + + /* Check the targets to be procedures of correct interface. */ + for (target = p->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + if (!gfc_check_operator_interface (target_proc, op, p->where)) + return FAILURE; + } + + return SUCCESS; + +error: + p->error = 1; + return FAILURE; +} + + +/* Resolve a type-bound user operator (tree-walker callback). */ static gfc_symbol* resolve_bindings_derived; static gfc_try resolve_bindings_result; +static gfc_try check_uop_procedure (gfc_symbol* sym, locus where); + +static void +resolve_typebound_user_op (gfc_symtree* stree) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + gcc_assert (stree && stree->n.tb); + + if (stree->n.tb->error) + return; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (stree->n.tb->is_generic); + + /* Find overridden procedure, if any. */ + super_type = gfc_get_derived_super_type (resolve_bindings_derived); + if (super_type && super_type->f2k_derived) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_user_op (super_type, NULL, + stree->name, true); + + if (overridden && overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; + } + else + stree->n.tb->overridden = NULL; + + /* Resolve basically using worker function. */ + if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name) + == FAILURE) + goto error; + + /* Check the targets to be functions of correct interface. */ + for (target = stree->n.tb->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE) + goto error; + } + + return; + +error: + resolve_bindings_result = FAILURE; + stree->n.tb->error = 1; +} + + +/* Resolve the type-bound procedures for a derived type. */ + static void resolve_typebound_procedure (gfc_symtree* stree) { @@ -9082,13 +9203,42 @@ error: static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { + int op; + bool found_op; + if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; resolve_bindings_derived = derived; resolve_bindings_result = SUCCESS; - gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, - &resolve_typebound_procedure); + + if (derived->f2k_derived->tb_sym_root) + gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, + &resolve_typebound_procedure); + + found_op = (derived->f2k_derived->tb_uop_root != NULL); + if (derived->f2k_derived->tb_uop_root) + gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, + &resolve_typebound_user_op); + + for (op = 0; op != GFC_INTRINSIC_OPS; ++op) + { + gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; + if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op, + p) == FAILURE) + resolve_bindings_result = FAILURE; + if (p) + found_op = true; + } + + /* FIXME: Remove this (and found_op) once calls are fully implemented. */ + if (found_op) + { + gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's," + " they are not yet implemented.", + derived->name, &derived->declared_at); + resolve_bindings_result = FAILURE; + } return resolve_bindings_result; } @@ -11063,67 +11213,94 @@ resolve_fntype (gfc_namespace *ns) } } + /* 12.3.2.1.1 Defined operators. */ -static void -gfc_resolve_uops (gfc_symtree *symtree) +static gfc_try +check_uop_procedure (gfc_symbol *sym, locus where) { - gfc_interface *itr; - gfc_symbol *sym; gfc_formal_arglist *formal; - if (symtree == NULL) - return; + if (!sym->attr.function) + { + gfc_error ("User operator procedure '%s' at %L must be a FUNCTION", + sym->name, &where); + return FAILURE; + } - gfc_resolve_uops (symtree->left); - gfc_resolve_uops (symtree->right); + if (sym->ts.type == BT_CHARACTER + && !(sym->ts.cl && sym->ts.cl->length) + && !(sym->result && sym->result->ts.cl + && sym->result->ts.cl->length)) + { + gfc_error ("User operator procedure '%s' at %L cannot be assumed " + "character length", sym->name, &where); + return FAILURE; + } - for (itr = symtree->n.uop->op; itr; itr = itr->next) + formal = sym->formal; + if (!formal || !formal->sym) { - sym = itr->sym; - if (!sym->attr.function) - gfc_error ("User operator procedure '%s' at %L must be a FUNCTION", - sym->name, &sym->declared_at); + gfc_error ("User operator procedure '%s' at %L must have at least " + "one argument", sym->name, &where); + return FAILURE; + } - if (sym->ts.type == BT_CHARACTER - && !(sym->ts.cl && sym->ts.cl->length) - && !(sym->result && sym->result->ts.cl - && sym->result->ts.cl->length)) - gfc_error ("User operator procedure '%s' at %L cannot be assumed " - "character length", sym->name, &sym->declared_at); + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &where); + return FAILURE; + } - formal = sym->formal; - if (!formal || !formal->sym) - { - gfc_error ("User operator procedure '%s' at %L must have at least " - "one argument", sym->name, &sym->declared_at); - continue; - } + if (formal->sym->attr.optional) + { + gfc_error ("First argument of operator interface at %L cannot be " + "optional", &where); + return FAILURE; + } - if (formal->sym->attr.intent != INTENT_IN) - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); + formal = formal->next; + if (!formal || !formal->sym) + return SUCCESS; - if (formal->sym->attr.optional) - gfc_error ("First argument of operator interface at %L cannot be " - "optional", &sym->declared_at); + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &where); + return FAILURE; + } - formal = formal->next; - if (!formal || !formal->sym) - continue; + if (formal->sym->attr.optional) + { + gfc_error ("Second argument of operator interface at %L cannot be " + "optional", &where); + return FAILURE; + } - if (formal->sym->attr.intent != INTENT_IN) - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); + if (formal->next) + { + gfc_error ("Operator interface at %L must have, at most, two " + "arguments", &where); + return FAILURE; + } - if (formal->sym->attr.optional) - gfc_error ("Second argument of operator interface at %L cannot be " - "optional", &sym->declared_at); + return SUCCESS; +} - if (formal->next) - gfc_error ("Operator interface at %L must have, at most, two " - "arguments", &sym->declared_at); - } +static void +gfc_resolve_uops (gfc_symtree *symtree) +{ + gfc_interface *itr; + + if (symtree == NULL) + return; + + gfc_resolve_uops (symtree->left); + gfc_resolve_uops (symtree->right); + + for (itr = symtree->n.uop->op; itr; itr = itr->next) + check_uop_procedure (itr->sym, itr->sym->declared_at); } -- cgit v1.2.1 From 2eb87b8cff6c679e334c03ac506465f994b70bed Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 13 Aug 2009 11:16:16 +0000 Subject: 2009-08-13 Janus Weil PR fortran/40995 * resolve.c (resolve_symbol): Move some checking code to resolve_intrinsic, and call this from here. (resolve_intrinsic): Some checking code moved here from resolve_symbol. Make sure each intrinsic is only resolved once. 2009-08-13 Janus Weil PR fortran/40995 * gfortran.dg/intrinsic_4.f90: New. * gfortran.dg/intrinsic_subroutine.f90: An error message moved to a different line. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150716 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 102 +++++++++++++++++++++++++------------------------- 1 file changed, 50 insertions(+), 52 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5c4370427d8..bc71af185df 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1148,24 +1148,64 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc) { - gfc_intrinsic_sym *isym = gfc_find_function (sym->name); - if (isym) + gfc_intrinsic_sym* isym; + const char* symstd; + + if (sym->formal) + return SUCCESS; + + /* We already know this one is an intrinsic, so we don't call + gfc_is_intrinsic for full checking but rather use gfc_find_function and + gfc_find_subroutine directly to check whether it is a function or + subroutine. */ + + if ((isym = gfc_find_function (sym->name))) { + if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising + && !sym->attr.implicit_type) + gfc_warning ("Type specified for intrinsic function '%s' at %L is" + " ignored", sym->name, &sym->declared_at); + if (!sym->attr.function && gfc_add_function (&sym->attr, sym->name, loc) == FAILURE) return FAILURE; + sym->ts = isym->ts; } - else + else if ((isym = gfc_find_subroutine (sym->name))) { - isym = gfc_find_subroutine (sym->name); - gcc_assert (isym); + if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) + { + gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type" + " specifier", sym->name, &sym->declared_at); + return FAILURE; + } + if (!sym->attr.subroutine && gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE) return FAILURE; } - if (!sym->formal) - gfc_copy_formal_args_intr (sym, isym); + else + { + gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name, + &sym->declared_at); + return FAILURE; + } + + gfc_copy_formal_args_intr (sym, isym); + + /* Check it is actually available in the standard settings. */ + if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at) + == FAILURE) + { + gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not" + " available in the current standard settings but %s. Use" + " an appropriate -std=* option or enable -fall-intrinsics" + " in order to use it.", + sym->name, &sym->declared_at, symstd); + return FAILURE; + } + return SUCCESS; } @@ -9944,51 +9984,9 @@ resolve_symbol (gfc_symbol *sym) /* Make sure that the intrinsic is consistent with its internal representation. This needs to be done before assigning a default type to avoid spurious warnings. */ - if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic) - { - gfc_intrinsic_sym* isym; - const char* symstd; - - /* We already know this one is an intrinsic, so we don't call - gfc_is_intrinsic for full checking but rather use gfc_find_function and - gfc_find_subroutine directly to check whether it is a function or - subroutine. */ - - if ((isym = gfc_find_function (sym->name))) - { - if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising - && !sym->attr.implicit_type) - gfc_warning ("Type specified for intrinsic function '%s' at %L is" - " ignored", sym->name, &sym->declared_at); - } - else if ((isym = gfc_find_subroutine (sym->name))) - { - if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) - { - gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type" - " specifier", sym->name, &sym->declared_at); - return; - } - } - else - { - gfc_error ("'%s' declared INTRINSIC at %L does not exist", - sym->name, &sym->declared_at); - return; - } - - /* Check it is actually available in the standard settings. */ - if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at) - == FAILURE) - { - gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not" - " available in the current standard settings but %s. Use" - " an appropriate -std=* option or enable -fall-intrinsics" - " in order to use it.", - sym->name, &sym->declared_at, symstd); - return; - } - } + if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic + && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) + return; /* Assign default type to symbols that need one and don't have one. */ if (sym->ts.type == BT_UNKNOWN) -- cgit v1.2.1 From eeebe20ba63ca092de5e2d4575b5765dd88a7ce6 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 13 Aug 2009 19:46:46 +0000 Subject: 2009-08-13 Janus Weil PR fortran/40941 * gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union. * decl.c (build_struct): Make sure 'cl' is only used if type is BT_CHARACTER. * symbol.c (gfc_set_default_type): Ditto. * resolve.c (resolve_symbol, resolve_fl_derived): Ditto. (resolve_equivalence,resolve_equivalence_derived): Make sure 'derived' is only used if type is BT_DERIVED. * trans-io.c (transfer_expr): Make sure 'derived' is only used if type is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR). * array.c: Mechanical replacements to accomodate union in gfc_typespec. * check.c: Ditto. * data.c: Ditto. * decl.c: Ditto. * dump-parse-tree.c: Ditto. * expr.c: Ditto. * interface.c: Ditto. * iresolve.c: Ditto. * match.c: Ditto. * misc.c: Ditto. * module.c: Ditto. * openmp.c: Ditto. * parse.c: Ditto. * primary.c: Ditto. * resolve.c: Ditto. * simplify.c: Ditto. * symbol.c: Ditto. * target-memory.c: Ditto. * trans-array.c: Ditto. * trans-common.c: Ditto. * trans-const.c: Ditto. * trans-decl.c: Ditto. * trans-expr.c: Ditto. * trans-intrinsic.c: Ditto. * trans-io.c: Ditto. * trans-stmt.c: Ditto. * trans-types.c: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150725 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 361 +++++++++++++++++++++++++------------------------- 1 file changed, 179 insertions(+), 182 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bc71af185df..9baef621eac 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -103,16 +103,16 @@ is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) static gfc_try resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) { - if (ts->type == BT_DERIVED && ts->derived->attr.abstract) + if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) { if (where) { if (name) gfc_error ("'%s' at %L is of the ABSTRACT type '%s'", - name, where, ts->derived->name); + name, where, ts->u.derived->name); else gfc_error ("ABSTRACT type '%s' used at %L", - ts->derived->name, where); + ts->u.derived->name, where); } return FAILURE; @@ -294,7 +294,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (sym->ts.type == BT_CHARACTER) { - gfc_charlen *cl = sym->ts.cl; + gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) { gfc_error ("Character-valued argument '%s' of statement " @@ -372,7 +372,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (sym->result->ts.type == BT_CHARACTER) { - gfc_charlen *cl = sym->result->ts.cl; + gfc_charlen *cl = sym->result->ts.u.cl; if (!cl || !cl->length) gfc_error ("Character-valued internal function '%s' at %L must " "not be assumed length", sym->name, &sym->declared_at); @@ -552,16 +552,16 @@ resolve_entries (gfc_namespace *ns) the same string length, i.e. both len=*, or both len=4. Having both len= is also possible, but difficult to check at compile time. */ - else if (ts->type == BT_CHARACTER && ts->cl && fts->cl - && (((ts->cl->length && !fts->cl->length) - ||(!ts->cl->length && fts->cl->length)) - || (ts->cl->length - && ts->cl->length->expr_type - != fts->cl->length->expr_type) - || (ts->cl->length - && ts->cl->length->expr_type == EXPR_CONSTANT - && mpz_cmp (ts->cl->length->value.integer, - fts->cl->length->value.integer) != 0))) + else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl + && (((ts->u.cl->length && !fts->u.cl->length) + ||(!ts->u.cl->length && fts->u.cl->length)) + || (ts->u.cl->length + && ts->u.cl->length->expr_type + != fts->u.cl->length->expr_type) + || (ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && mpz_cmp (ts->u.cl->length->value.integer, + fts->u.cl->length->value.integer) != 0))) gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with " "entries returning variables of different " "string lengths", ns->entries->sym->name, @@ -688,7 +688,7 @@ has_default_initializer (gfc_symbol *der) for (c = der->components; c; c = c->next) if ((c->ts.type != BT_DERIVED && c->initializer) || (c->ts.type == BT_DERIVED - && (!c->attr.pointer && has_default_initializer (c->ts.derived)))) + && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) break; return c != NULL; @@ -718,16 +718,16 @@ resolve_common_vars (gfc_symbol *sym, bool named_common) if (csym->ts.type != BT_DERIVED) continue; - if (!(csym->ts.derived->attr.sequence - || csym->ts.derived->attr.is_bind_c)) + if (!(csym->ts.u.derived->attr.sequence + || csym->ts.u.derived->attr.is_bind_c)) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "has neither the SEQUENCE nor the BIND(C) " "attribute", csym->name, &csym->declared_at); - if (csym->ts.derived->attr.alloc_comp) + if (csym->ts.u.derived->attr.alloc_comp) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "has an ultimate component that is " "allocatable", csym->name, &csym->declared_at); - if (has_default_initializer (csym->ts.derived)) + if (has_default_initializer (csym->ts.u.derived)) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "may not have default initializer", csym->name, &csym->declared_at); @@ -826,15 +826,15 @@ resolve_structure_cons (gfc_expr *expr) if (expr->ref) comp = expr->ref->u.c.sym->components; else - comp = expr->ts.derived->components; + comp = expr->ts.u.derived->components; /* See if the user is trying to invoke a structure constructor for one of the iso_c_binding derived types. */ - if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons + if (expr->ts.u.derived && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL) { gfc_error ("Components of structure constructor '%s' at %L are PRIVATE", - expr->ts.derived->name, &(expr->where)); + expr->ts.u.derived->name, &(expr->where)); return FAILURE; } @@ -2191,9 +2191,9 @@ is_scalar_expr_ptr (gfc_expr *expr) its length is one. */ if (expr->ts.type == BT_CHARACTER) { - if (expr->ts.cl == NULL - || expr->ts.cl->length == NULL - || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) + if (expr->ts.u.cl == NULL + || expr->ts.u.cl->length == NULL + || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0) retval = FAILURE; } @@ -2224,9 +2224,9 @@ is_scalar_expr_ptr (gfc_expr *expr) else if (expr->ts.type == BT_CHARACTER && expr->rank == 0) { /* Character string. Make sure it's of length 1. */ - if (expr->ts.cl == NULL - || expr->ts.cl->length == NULL - || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0) + if (expr->ts.u.cl == NULL + || expr->ts.u.cl->length == NULL + || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0) retval = FAILURE; } else if (expr->rank != 0) @@ -2376,12 +2376,12 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, any type should be ok if the variable is of a C interoperable type. */ if (arg_ts->type == BT_CHARACTER) - if (arg_ts->cl != NULL - && (arg_ts->cl->length == NULL - || arg_ts->cl->length->expr_type + if (arg_ts->u.cl != NULL + && (arg_ts->u.cl->length == NULL + || arg_ts->u.cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si - (arg_ts->cl->length->value.integer, 1) + (arg_ts->u.cl->length->value.integer, 1) != 0) && is_scalar_expr_ptr (args->expr) != SUCCESS) { @@ -2536,8 +2536,8 @@ resolve_function (gfc_expr *expr) &expr->value.function.actual, 0); if (sym && sym->ts.type == BT_CHARACTER - && sym->ts.cl - && sym->ts.cl->length == NULL + && sym->ts.u.cl + && sym->ts.u.cl->length == NULL && !sym->attr.dummy && expr->value.function.esym == NULL && !sym->attr.contained) @@ -2687,7 +2687,7 @@ resolve_function (gfc_expr *expr) if (expr->ts.type == BT_CHARACTER && expr->value.function.esym && expr->value.function.esym->attr.use_assoc) { - gfc_expr_set_symbols_referenced (expr->ts.cl->length); + gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); } if (t == SUCCESS @@ -3396,7 +3396,7 @@ resolve_operator (gfc_expr *e) case INTRINSIC_PARENTHESES: e->ts = op1->ts; if (e->ts.type == BT_CHARACTER) - e->ts.cl = op1->ts.cl; + e->ts.u.cl = op1->ts.u.cl; break; default: @@ -3924,7 +3924,7 @@ find_array_spec (gfc_expr *e) case REF_COMPONENT: if (derived == NULL) - derived = e->symtree->n.sym->ts.derived; + derived = e->symtree->n.sym->ts.u.derived; c = derived->components; @@ -3933,7 +3933,7 @@ find_array_spec (gfc_expr *e) { /* Track the sequence of component references. */ if (c->ts.type == BT_DERIVED) - derived = c->ts.derived; + derived = c->ts.u.derived; break; } @@ -4116,10 +4116,10 @@ gfc_resolve_substring_charlen (gfc_expr *e) gcc_assert (char_ref->next == NULL); - if (e->ts.cl) + if (e->ts.u.cl) { - if (e->ts.cl->length) - gfc_free_expr (e->ts.cl->length); + if (e->ts.u.cl->length) + gfc_free_expr (e->ts.u.cl->length); else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) return; @@ -4128,8 +4128,8 @@ gfc_resolve_substring_charlen (gfc_expr *e) e->ts.type = BT_CHARACTER; e->ts.kind = gfc_default_character_kind; - if (!e->ts.cl) - e->ts.cl = gfc_new_charlen (gfc_current_ns); + if (!e->ts.u.cl) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns); if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); @@ -4139,7 +4139,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) if (char_ref->u.ss.end) end = gfc_copy_expr (char_ref->u.ss.end); else if (e->expr_type == EXPR_VARIABLE) - end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length); + end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); else end = NULL; @@ -4147,15 +4147,15 @@ gfc_resolve_substring_charlen (gfc_expr *e) return; /* Length = (end - start +1). */ - e->ts.cl->length = gfc_subtract (end, start); - e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1)); + e->ts.u.cl->length = gfc_subtract (end, start); + e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1)); - e->ts.cl->length->ts.type = BT_INTEGER; - e->ts.cl->length->ts.kind = gfc_charlen_int_kind; + e->ts.u.cl->length->ts.type = BT_INTEGER; + e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; /* Make sure that the length is simplified. */ - gfc_simplify_expr (e->ts.cl->length, 1); - gfc_resolve_expr (e->ts.cl->length); + gfc_simplify_expr (e->ts.u.cl->length, 1); + gfc_resolve_expr (e->ts.u.cl->length); } @@ -4447,7 +4447,7 @@ resolve_variable (gfc_expr *e) /* Now do the same check on the specification expressions. */ specification_expr = 1; if (sym->ts.type == BT_CHARACTER - && gfc_resolve_expr (sym->ts.cl->length) == FAILURE) + && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE) t = FAILURE; if (sym->as) @@ -4592,26 +4592,26 @@ gfc_resolve_character_operator (gfc_expr *e) gcc_assert (e->value.op.op == INTRINSIC_CONCAT); - if (op1->ts.cl && op1->ts.cl->length) - e1 = gfc_copy_expr (op1->ts.cl->length); + if (op1->ts.u.cl && op1->ts.u.cl->length) + e1 = gfc_copy_expr (op1->ts.u.cl->length); else if (op1->expr_type == EXPR_CONSTANT) e1 = gfc_int_expr (op1->value.character.length); - if (op2->ts.cl && op2->ts.cl->length) - e2 = gfc_copy_expr (op2->ts.cl->length); + if (op2->ts.u.cl && op2->ts.u.cl->length) + e2 = gfc_copy_expr (op2->ts.u.cl->length); else if (op2->expr_type == EXPR_CONSTANT) e2 = gfc_int_expr (op2->value.character.length); - e->ts.cl = gfc_new_charlen (gfc_current_ns); + e->ts.u.cl = gfc_new_charlen (gfc_current_ns); if (!e1 || !e2) return; - e->ts.cl->length = gfc_add (e1, e2); - e->ts.cl->length->ts.type = BT_INTEGER; - e->ts.cl->length->ts.kind = gfc_charlen_int_kind; - gfc_simplify_expr (e->ts.cl->length, 0); - gfc_resolve_expr (e->ts.cl->length); + e->ts.u.cl->length = gfc_add (e1, e2); + e->ts.u.cl->length->ts.type = BT_INTEGER; + e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; + gfc_simplify_expr (e->ts.u.cl->length, 0); + gfc_resolve_expr (e->ts.u.cl->length); return; } @@ -4636,12 +4636,12 @@ fixup_charlen (gfc_expr *e) gfc_resolve_character_array_constructor (e); case EXPR_SUBSTRING: - if (!e->ts.cl && e->ref) + if (!e->ts.u.cl && e->ref) gfc_resolve_substring_charlen (e); default: - if (!e->ts.cl) - e->ts.cl = gfc_new_charlen (gfc_current_ns); + if (!e->ts.u.cl) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns); break; } @@ -4817,10 +4817,10 @@ check_typebound_baseobject (gfc_expr* e) return FAILURE; gcc_assert (base->ts.type == BT_DERIVED); - if (base->ts.derived->attr.abstract) + if (base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" - " ABSTRACT type '%s'", &e->where, base->ts.derived->name); + " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name); return FAILURE; } @@ -5111,7 +5111,7 @@ gfc_resolve_expr (gfc_expr *e) expression_rank (e); } - if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref + if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref && e->ref->type != REF_SUBSTRING) gfc_resolve_substring_charlen (e); @@ -5171,7 +5171,7 @@ gfc_resolve_expr (gfc_expr *e) gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); } - if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl) + if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) fixup_charlen (e); return t; @@ -5414,7 +5414,7 @@ derived_inaccessible (gfc_symbol *sym) for (c = sym->components; c; c = c->next) { - if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived)) + if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) return 1; } @@ -6344,21 +6344,21 @@ resolve_transfer (gfc_code *code) { /* Check that transferred derived type doesn't contain POINTER components. */ - if (ts->derived->attr.pointer_comp) + if (ts->u.derived->attr.pointer_comp) { gfc_error ("Data transfer element at %L cannot have " "POINTER components", &code->loc); return; } - if (ts->derived->attr.alloc_comp) + if (ts->u.derived->attr.alloc_comp) { gfc_error ("Data transfer element at %L cannot have " "ALLOCATABLE components", &code->loc); return; } - if (derived_inaccessible (ts->derived)) + if (derived_inaccessible (ts->u.derived)) { gfc_error ("Data transfer element at %L cannot have " "PRIVATE components",&code->loc); @@ -6925,7 +6925,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) and rhs is the same symbol as the lhs. */ if (rhs->expr_type == EXPR_VARIABLE && rhs->symtree->n.sym->ts.type == BT_DERIVED - && has_default_initializer (rhs->symtree->n.sym->ts.derived) + && has_default_initializer (rhs->symtree->n.sym->ts.u.derived) && (lhs->symtree->n.sym == rhs->symtree->n.sym)) code->ext.actual->next->expr = gfc_get_parentheses (rhs); @@ -6974,18 +6974,18 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (lhs->ts.type == BT_CHARACTER && gfc_option.warn_character_truncation) { - if (lhs->ts.cl != NULL - && lhs->ts.cl->length != NULL - && lhs->ts.cl->length->expr_type == EXPR_CONSTANT) - llen = mpz_get_si (lhs->ts.cl->length->value.integer); + if (lhs->ts.u.cl != NULL + && lhs->ts.u.cl->length != NULL + && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) + llen = mpz_get_si (lhs->ts.u.cl->length->value.integer); if (rhs->expr_type == EXPR_CONSTANT) rlen = rhs->value.character.length; - else if (rhs->ts.cl != NULL - && rhs->ts.cl->length != NULL - && rhs->ts.cl->length->expr_type == EXPR_CONSTANT) - rlen = mpz_get_si (rhs->ts.cl->length->value.integer); + else if (rhs->ts.u.cl != NULL + && rhs->ts.u.cl->length != NULL + && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) + rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer); if (rlen && llen && rlen > llen) gfc_warning_now ("CHARACTER expression will be truncated " @@ -7022,7 +7022,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (lhs->ts.type == BT_DERIVED && lhs->expr_type == EXPR_VARIABLE - && lhs->ts.derived->attr.pointer_comp + && lhs->ts.u.derived->attr.pointer_comp && gfc_impure_variable (rhs->symtree->n.sym)) { gfc_error ("The impure variable at %L is assigned to " @@ -7716,7 +7716,7 @@ apply_default_init (gfc_symbol *sym) if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) return; - if (sym->ts.type == BT_DERIVED && sym->ts.derived) + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) init = gfc_default_initializer (&sym->ts); if (init == NULL) @@ -7861,10 +7861,10 @@ build_default_init_expr (gfc_symbol *sym) /* For characters, the length must be constant in order to create a default initializer. */ if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON - && sym->ts.cl->length - && sym->ts.cl->length->expr_type == EXPR_CONSTANT) + && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - char_len = mpz_get_si (sym->ts.cl->length->value.integer); + char_len = mpz_get_si (sym->ts.u.cl->length->value.integer); init_expr->value.character.length = char_len; init_expr->value.character.string = gfc_get_wide_string (char_len+1); for (i = 0; i < char_len; i++) @@ -7977,17 +7977,17 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) associated by the presence of another class I symbol in the same namespace. 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */ - if (sym->ns != sym->ts.derived->ns + if (sym->ns != sym->ts.u.derived->ns && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) { gfc_symbol *s; - gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s); + gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); if (s && s->attr.flavor != FL_DERIVED) { gfc_error ("The type '%s' cannot be host associated at %L " "because it is blocked by an incompatible object " "of the same name declared at %L", - sym->ts.derived->name, &sym->declared_at, + sym->ts.u.derived->name, &sym->declared_at, &s->declared_at); return FAILURE; } @@ -8005,7 +8005,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) && sym->ns->proc_name->attr.flavor == FL_MODULE && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable - && has_default_initializer (sym->ts.derived)) + && has_default_initializer (sym->ts.u.derived)) { gfc_error("Object '%s' at %L must have the SAVE attribute for " "default initialization of a component", @@ -8016,10 +8016,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) if (sym->ts.is_class) { /* C502. */ - if (!type_is_extensible (sym->ts.derived)) + if (!type_is_extensible (sym->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.derived->name, sym->name, &sym->declared_at); + sym->ts.u.derived->name, sym->name, &sym->declared_at); return FAILURE; } @@ -8083,7 +8083,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) { /* Make sure that character string variables with assumed length are dummy arguments. */ - e = sym->ts.cl->length; + e = sym->ts.u.cl->length; if (e == NULL && !sym->attr.dummy && !sym->attr.result) { gfc_error ("Entity with assumed character length at %L must be a " @@ -8189,7 +8189,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CHARACTER) { - gfc_charlen *cl = sym->ts.cl; + gfc_charlen *cl = sym->ts.u.cl; if (cl && cl->length && gfc_is_constant_expr (cl->length) && resolve_charlen (cl) == FAILURE) @@ -8229,9 +8229,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (arg->sym && arg->sym->ts.type == BT_DERIVED - && !arg->sym->ts.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.derived->attr.access, - arg->sym->ts.derived->ns->default_access) + && !arg->sym->ts.u.derived->attr.use_assoc + && !gfc_check_access (arg->sym->ts.u.derived->attr.access, + arg->sym->ts.u.derived->ns->default_access) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a " "PRIVATE type and cannot be a dummy argument" " of '%s', which is PUBLIC at %L", @@ -8239,7 +8239,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) == FAILURE) { /* Stop this message from recurring. */ - arg->sym->ts.derived->attr.access = ACCESS_PUBLIC; + arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; return FAILURE; } } @@ -8252,9 +8252,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (arg->sym && arg->sym->ts.type == BT_DERIVED - && !arg->sym->ts.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.derived->attr.access, - arg->sym->ts.derived->ns->default_access) + && !arg->sym->ts.u.derived->attr.use_assoc + && !gfc_check_access (arg->sym->ts.u.derived->attr.access, + arg->sym->ts.u.derived->ns->default_access) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " @@ -8263,7 +8263,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) gfc_typename (&arg->sym->ts)) == FAILURE) { /* Stop this message from recurring. */ - arg->sym->ts.derived->attr.access = ACCESS_PUBLIC; + arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; return FAILURE; } } @@ -8277,9 +8277,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (arg->sym && arg->sym->ts.type == BT_DERIVED - && !arg->sym->ts.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.derived->attr.access, - arg->sym->ts.derived->ns->default_access) + && !arg->sym->ts.u.derived->attr.use_assoc + && !gfc_check_access (arg->sym->ts.u.derived->attr.access, + arg->sym->ts.u.derived->ns->default_access) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " @@ -8288,7 +8288,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) gfc_typename (&arg->sym->ts)) == FAILURE) { /* Stop this message from recurring. */ - arg->sym->ts.derived->attr.access = ACCESS_PUBLIC; + arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; return FAILURE; } } @@ -8330,7 +8330,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) function - but length must be declared in calling scoping unit. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER - && sym->ts.cl && sym->ts.cl->length == NULL) + && sym->ts.u.cl && sym->ts.u.cl->length == NULL) { if ((sym->as && sym->as->rank) || (sym->attr.pointer) || (sym->attr.recursive) || (sym->attr.pure)) @@ -8499,7 +8499,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) arg = list->proc_sym->formal->sym; /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived) + if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) { gfc_error ("Argument of FINAL procedure at %L must be of type '%s'", &arg->declared_at, derived->name); @@ -9181,7 +9181,7 @@ resolve_typebound_procedure (gfc_symtree* stree) /* Now check that the argument-type matches. */ gcc_assert (me_arg); if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.derived != resolve_bindings_derived) + || me_arg->ts.u.derived != resolve_bindings_derived) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived-type '%s'", me_arg->name, proc->name, @@ -9450,12 +9450,12 @@ resolve_fl_derived (gfc_symbol *sym) } } /* Copy char length. */ - if (ifc->ts.cl) + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - c->ts.cl = gfc_new_charlen (sym->ns); - c->ts.cl->resolved = ifc->ts.cl->resolved; - c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length); - /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/ + c->ts.u.cl = gfc_new_charlen (sym->ns); + c->ts.u.cl->resolved = ifc->ts.u.cl->resolved; + c->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length); + /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/ } } else if (c->ts.interface->name[0] != '\0') @@ -9524,7 +9524,7 @@ resolve_fl_derived (gfc_symbol *sym) /* Now check that the argument-type matches. */ gcc_assert (me_arg); if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.derived != sym) + || me_arg->ts.u.derived != sym) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived type '%s'", me_arg->name, c->name, @@ -9585,14 +9585,14 @@ resolve_fl_derived (gfc_symbol *sym) if (c->ts.type == BT_CHARACTER) { - if (c->ts.cl->length == NULL - || (resolve_charlen (c->ts.cl) == FAILURE) - || !gfc_is_constant_expr (c->ts.cl->length)) + if (c->ts.u.cl->length == NULL + || (resolve_charlen (c->ts.u.cl) == FAILURE) + || !gfc_is_constant_expr (c->ts.u.cl->length)) { gfc_error ("Character length of component '%s' needs to " "be a constant specification expression at %L", c->name, - c->ts.cl->length ? &c->ts.cl->length->where : &c->loc); + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); return FAILURE; } } @@ -9600,10 +9600,10 @@ resolve_fl_derived (gfc_symbol *sym) if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE && gfc_check_access (sym->attr.access, sym->ns->default_access) - && !is_sym_host_assoc (c->ts.derived, sym->ns) - && !c->ts.derived->attr.use_assoc - && !gfc_check_access (c->ts.derived->attr.access, - c->ts.derived->ns->default_access) + && !is_sym_host_assoc (c->ts.u.derived, sym->ns) + && !c->ts.u.derived->attr.use_assoc + && !gfc_check_access (c->ts.u.derived->attr.access, + c->ts.u.derived->ns->default_access) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " "is a PRIVATE type and cannot be a component of " "'%s', which is PUBLIC at %L", c->name, @@ -9612,18 +9612,18 @@ resolve_fl_derived (gfc_symbol *sym) if (sym->attr.sequence) { - if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0) + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) { gfc_error ("Component %s of SEQUENCE type declared at %L does " "not have the SEQUENCE attribute", - c->ts.derived->name, &sym->declared_at); + c->ts.u.derived->name, &sym->declared_at); return FAILURE; } } if (c->ts.type == BT_DERIVED && c->attr.pointer - && c->ts.derived->components == NULL - && !c->ts.derived->attr.zero_comp) + && c->ts.u.derived->components == NULL + && !c->ts.u.derived->attr.zero_comp) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " "that has not been declared", c->name, sym->name, @@ -9644,11 +9644,11 @@ resolve_fl_derived (gfc_symbol *sym) derived type list; even in formal namespaces, where derived type pointer components might not have been declared. */ if (c->ts.type == BT_DERIVED - && c->ts.derived - && c->ts.derived->components + && c->ts.u.derived + && c->ts.u.derived->components && c->attr.pointer - && sym != c->ts.derived) - add_dt_to_dt_list (c->ts.derived); + && sym != c->ts.u.derived) + add_dt_to_dt_list (c->ts.u.derived); if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable || c->as == NULL) @@ -9716,7 +9716,7 @@ resolve_fl_namelist (gfc_symbol *sym) /* Types with private components that came here by USE-association. */ if (nl->sym->ts.type == BT_DERIVED - && derived_inaccessible (nl->sym->ts.derived)) + && derived_inaccessible (nl->sym->ts.u.derived)) { gfc_error ("NAMELIST object '%s' has use-associated PRIVATE " "components and cannot be member of namelist '%s' at %L", @@ -9726,8 +9726,8 @@ resolve_fl_namelist (gfc_symbol *sym) /* Types with private components that are defined in the same module. */ if (nl->sym->ts.type == BT_DERIVED - && !is_sym_host_assoc (nl->sym->ts.derived, sym->ns) - && !gfc_check_access (nl->sym->ts.derived->attr.private_comp + && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) + && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp ? ACCESS_PRIVATE : ACCESS_UNKNOWN, nl->sym->ns->default_access)) { @@ -9762,7 +9762,7 @@ resolve_fl_namelist (gfc_symbol *sym) if (nl->sym->ts.type != BT_DERIVED) continue; - if (nl->sym->ts.derived->attr.alloc_comp) + if (nl->sym->ts.u.derived->attr.alloc_comp) { gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " "have ALLOCATABLE components", @@ -9770,7 +9770,7 @@ resolve_fl_namelist (gfc_symbol *sym) return FAILURE; } - if (nl->sym->ts.derived->attr.pointer_comp) + if (nl->sym->ts.u.derived->attr.pointer_comp) { gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " "have POINTER components", @@ -9954,12 +9954,12 @@ resolve_symbol (gfc_symbol *sym) } } /* Copy char length. */ - if (ifc->ts.cl) + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - sym->ts.cl = gfc_new_charlen (sym->ns); - sym->ts.cl->resolved = ifc->ts.cl->resolved; - sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length); - gfc_expr_replace_symbols (sym->ts.cl->length, sym); + sym->ts.u.cl = gfc_new_charlen (sym->ns); + sym->ts.u.cl->resolved = ifc->ts.u.cl->resolved; + sym->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length); + gfc_expr_replace_symbols (sym->ts.u.cl->length, sym); } } else if (sym->ts.interface->name[0] != '\0') @@ -10059,7 +10059,7 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.value && sym->ts.type == BT_CHARACTER) { - gfc_charlen *cl = sym->ts.cl; + gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) { gfc_error ("Character dummy variable '%s' at %L with VALUE " @@ -10111,14 +10111,14 @@ resolve_symbol (gfc_symbol *sym) /* If type() declaration, we need to verify that the components of the given type are all C interoperable, etc. */ if (sym->ts.type == BT_DERIVED && - sym->ts.derived->attr.is_c_interop != 1) + sym->ts.u.derived->attr.is_c_interop != 1) { /* Make sure the user marked the derived type as BIND(C). If not, call the verify routine. This could print an error for the derived type more than once if multiple variables of that type are declared. */ - if (sym->ts.derived->attr.is_bind_c != 1) - verify_bind_c_derived_type (sym->ts.derived); + if (sym->ts.u.derived->attr.is_bind_c != 1) + verify_bind_c_derived_type (sym->ts.u.derived); t = FAILURE; } @@ -10147,12 +10147,12 @@ resolve_symbol (gfc_symbol *sym) the type is not declared in the scope of the implicit statement. Change the type to BT_UNKNOWN, both because it is so and to prevent an ICE. */ - if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL - && !sym->ts.derived->attr.zero_comp) + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL + && !sym->ts.u.derived->attr.zero_comp) { gfc_error ("The derived type '%s' at %L is of type '%s', " "which has not been defined", sym->name, - &sym->declared_at, sym->ts.derived->name); + &sym->declared_at, sym->ts.u.derived->name); sym->ts.type = BT_UNKNOWN; return; } @@ -10161,23 +10161,23 @@ resolve_symbol (gfc_symbol *sym) derived type is visible in the symbol's namespace, if it is a module function and is not PRIVATE. */ if (sym->ts.type == BT_DERIVED - && sym->ts.derived->attr.use_assoc + && sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE) { gfc_symbol *ds; - if (resolve_fl_derived (sym->ts.derived) == FAILURE) + if (resolve_fl_derived (sym->ts.u.derived) == FAILURE) return; - gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds); + gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds); if (!ds && sym->attr.function && gfc_check_access (sym->attr.access, sym->ns->default_access)) { symtree = gfc_new_symtree (&sym->ns->sym_root, - sym->ts.derived->name); - symtree->n.sym = sym->ts.derived; - sym->ts.derived->refs++; + sym->ts.u.derived->name); + symtree->n.sym = sym->ts.u.derived; + sym->ts.u.derived->refs++; } } @@ -10187,15 +10187,15 @@ resolve_symbol (gfc_symbol *sym) 161 in 95-006r3. */ if (sym->ts.type == BT_DERIVED && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE - && !sym->ts.derived->attr.use_assoc + && !sym->ts.u.derived->attr.use_assoc && gfc_check_access (sym->attr.access, sym->ns->default_access) - && !gfc_check_access (sym->ts.derived->attr.access, - sym->ts.derived->ns->default_access) + && !gfc_check_access (sym->ts.u.derived->attr.access, + sym->ts.u.derived->ns->default_access) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L " "of PRIVATE derived type '%s'", (sym->attr.flavor == FL_PARAMETER) ? "parameter" : "variable", sym->name, &sym->declared_at, - sym->ts.derived->name) == FAILURE) + sym->ts.u.derived->name) == FAILURE) return; /* An assumed-size array with INTENT(OUT) shall not be of a type for which @@ -10206,7 +10206,7 @@ resolve_symbol (gfc_symbol *sym) && sym->as && sym->as->type == AS_ASSUMED_SIZE) { - for (c = sym->ts.derived->components; c; c = c->next) + for (c = sym->ts.u.derived->components; c; c = c->next) { if (c->initializer) { @@ -10810,11 +10810,11 @@ sequence_type (gfc_typespec ts) { case BT_DERIVED: - if (ts.derived->components == NULL) + if (ts.u.derived->components == NULL) return SEQ_NONDEFAULT; - result = sequence_type (ts.derived->components->ts); - for (c = ts.derived->components->next; c; c = c->next) + result = sequence_type (ts.u.derived->components->ts); + for (c = ts.u.derived->components->next; c; c = c->next) if (sequence_type (c->ts) != result) return SEQ_MIXED; @@ -10862,7 +10862,6 @@ sequence_type (gfc_typespec ts) static gfc_try resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) { - gfc_symbol *d; gfc_component *c = derived->components; if (!derived) @@ -10886,7 +10885,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) return FAILURE; } - if (sym->attr.in_common && has_default_initializer (sym->ts.derived)) + if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived)) { gfc_error ("Derived type variable '%s' at %L with default " "initialization cannot be in EQUIVALENCE with a variable " @@ -10896,9 +10895,8 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) for (; c ; c = c->next) { - d = c->ts.derived; - if (d - && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE)) + if (c->ts.type == BT_DERIVED + && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE)) return FAILURE; /* Shall not be an object of sequence derived type containing a pointer @@ -10932,7 +10930,6 @@ static void resolve_equivalence (gfc_equiv *eq) { gfc_symbol *sym; - gfc_symbol *derived; gfc_symbol *first_sym; gfc_expr *e; gfc_ref *r; @@ -10996,11 +10993,11 @@ resolve_equivalence (gfc_equiv *eq) if (start == NULL) start = gfc_int_expr (1); ref->u.ss.start = start; - if (end == NULL && e->ts.cl) - end = gfc_copy_expr (e->ts.cl->length); + if (end == NULL && e->ts.u.cl) + end = gfc_copy_expr (e->ts.u.cl->length); ref->u.ss.end = end; - ref->u.ss.length = e->ts.cl; - e->ts.cl = NULL; + ref->u.ss.length = e->ts.u.cl; + e->ts.u.cl = NULL; } ref = ref->next; gfc_free (mem); @@ -11051,8 +11048,8 @@ resolve_equivalence (gfc_equiv *eq) continue; } - derived = e->ts.derived; - if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE) + if (e->ts.type == BT_DERIVED + && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE) continue; /* Check that the types correspond correctly: @@ -11185,15 +11182,15 @@ resolve_fntype (gfc_namespace *ns) sym->attr.untyped = 1; } - if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc + if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc && !sym->attr.contained - && !gfc_check_access (sym->ts.derived->attr.access, - sym->ts.derived->ns->default_access) + && !gfc_check_access (sym->ts.u.derived->attr.access, + sym->ts.u.derived->ns->default_access) && gfc_check_access (sym->attr.access, sym->ns->default_access)) { gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at " "%L of PRIVATE type '%s'", sym->name, - &sym->declared_at, sym->ts.derived->name); + &sym->declared_at, sym->ts.u.derived->name); } if (ns->entries) @@ -11227,9 +11224,9 @@ check_uop_procedure (gfc_symbol *sym, locus where) } if (sym->ts.type == BT_CHARACTER - && !(sym->ts.cl && sym->ts.cl->length) - && !(sym->result && sym->result->ts.cl - && sym->result->ts.cl->length)) + && !(sym->ts.u.cl && sym->ts.u.cl->length) + && !(sym->result && sym->result->ts.u.cl + && sym->result->ts.u.cl->length)) { gfc_error ("User operator procedure '%s' at %L cannot be assumed " "character length", sym->name, &where); -- cgit v1.2.1 From 3f75cac2238688b5654cb70c046ae2c1711a0066 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 14 Aug 2009 22:02:45 +0000 Subject: 2009-08-14 Janus Weil PR fortran/41070 * resolve.c (resolve_structure_cons): Make sure that ts.u.derived is only used if type is BT_DERIVED. 2009-08-14 Janus Weil PR fortran/41070 * gfortran.dg/structure_constructor_10.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150781 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9baef621eac..ff32ae6e21d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -830,8 +830,8 @@ resolve_structure_cons (gfc_expr *expr) /* See if the user is trying to invoke a structure constructor for one of the iso_c_binding derived types. */ - if (expr->ts.u.derived && expr->ts.u.derived->ts.is_iso_c && cons - && cons->expr != NULL) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived + && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL) { gfc_error ("Components of structure constructor '%s' at %L are PRIVATE", expr->ts.u.derived->name, &(expr->where)); -- cgit v1.2.1 From d270ce529b4bdd51b952f8ed87746b9e77ada4c2 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 Aug 2009 09:11:00 +0000 Subject: 2009-08-17 Janus Weil PR fortran/40877 * array.c (gfc_resolve_character_array_constructor): Add NULL argument to gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (simplify_const_ref): Fix memory leak. (gfc_simplify_expr): Add NULL argument to gfc_new_charlen. * gfortran.h (gfc_new_charlen): Modified prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Add NULL argument to gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen): Ditto. (resolve_fl_derived,resolve_symbol): Add argument to gfc_charlen. * symbol.c (gfc_new_charlen): Add argument 'old_cl' (to make a copy of an existing charlen). (gfc_set_default_type,generate_isocbinding_symbol): Fix memory leak. (gfc_copy_formal_args_intr): Add NULL argument to gfc_new_charlen. * trans-decl.c (create_function_arglist): Fix memory leak. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150823 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ff32ae6e21d..fb72b938bee 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4129,7 +4129,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) e->ts.kind = gfc_default_character_kind; if (!e->ts.u.cl) - e->ts.u.cl = gfc_new_charlen (gfc_current_ns); + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); @@ -4602,7 +4602,7 @@ gfc_resolve_character_operator (gfc_expr *e) else if (op2->expr_type == EXPR_CONSTANT) e2 = gfc_int_expr (op2->value.character.length); - e->ts.u.cl = gfc_new_charlen (gfc_current_ns); + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); if (!e1 || !e2) return; @@ -4641,7 +4641,7 @@ fixup_charlen (gfc_expr *e) default: if (!e->ts.u.cl) - e->ts.u.cl = gfc_new_charlen (gfc_current_ns); + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); break; } @@ -9452,9 +9452,7 @@ resolve_fl_derived (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - c->ts.u.cl = gfc_new_charlen (sym->ns); - c->ts.u.cl->resolved = ifc->ts.u.cl->resolved; - c->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length); + c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/ } } @@ -9956,9 +9954,7 @@ resolve_symbol (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - sym->ts.u.cl = gfc_new_charlen (sym->ns); - sym->ts.u.cl->resolved = ifc->ts.u.cl->resolved; - sym->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length); + sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); gfc_expr_replace_symbols (sym->ts.u.cl->length, sym); } } -- cgit v1.2.1 From a00a2d4b0e0d835085b5eccf7ec1cf9a6efe27e1 Mon Sep 17 00:00:00 2001 From: domob Date: Mon, 17 Aug 2009 18:55:30 +0000 Subject: 2009-08-17 Daniel Kraft PR fortran/37425 * resolve.c (get_checked_tb_operator_target): New routine to do checks on type-bound operators in common between intrinsic and user operators. (resolve_typebound_intrinsic_op): Call it. (resolve_typebound_user_op): Ditto. 2009-08-17 Daniel Kraft PR fortran/37425 * gfortran.dg/typebound_operator_2.f03: Test for error with illegal NOPASS bindings as operators. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150856 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fb72b938bee..4f99aba0708 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8965,6 +8965,29 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) } +/* Retrieve the target-procedure of an operator binding and do some checks in + common for intrinsic and user-defined type-bound operators. */ + +static gfc_symbol* +get_checked_tb_operator_target (gfc_tbp_generic* target, locus where) +{ + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + /* All operator bindings must have a passed-object dummy argument. */ + if (target->specific->nopass) + { + gfc_error ("Type-bound operator at %L can't be NOPASS", &where); + return NULL; + } + + return target_proc; +} + + /* Resolve a type-bound intrinsic operator. */ static gfc_try @@ -8998,9 +9021,9 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, { gfc_symbol* target_proc; - gcc_assert (target->specific && !target->specific->is_generic); - target_proc = target->specific->u.specific->n.sym; - gcc_assert (target_proc); + target_proc = get_checked_tb_operator_target (target, p->where); + if (!target_proc) + return FAILURE; if (!gfc_check_operator_interface (target_proc, op, p->where)) return FAILURE; @@ -9059,9 +9082,9 @@ resolve_typebound_user_op (gfc_symtree* stree) { gfc_symbol* target_proc; - gcc_assert (target->specific && !target->specific->is_generic); - target_proc = target->specific->u.specific->n.sym; - gcc_assert (target_proc); + target_proc = get_checked_tb_operator_target (target, stree->n.tb->where); + if (!target_proc) + goto error; if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE) goto error; -- cgit v1.2.1 From daaffbaed421200205743c4e21cb2f9182028bce Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 20 Aug 2009 09:33:01 +0000 Subject: 2009-08-20 Janus Weil PR fortran/41121 * resolve.c (resolve_symbol): Don't resolve formal_ns of intrinsic procedures. 2009-08-20 Janus Weil PR fortran/41121 * gfortran.dg/intrinsic_5.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150957 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4f99aba0708..3782bb27e85 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10280,7 +10280,7 @@ resolve_symbol (gfc_symbol *sym) /* Resolve formal namespaces. */ if (sym->formal_ns && sym->formal_ns != gfc_current_ns - && !sym->attr.contained) + && !sym->attr.contained && !sym->attr.intrinsic) gfc_resolve (sym->formal_ns); /* Make sure the formal namespace is present. */ -- cgit v1.2.1 From 1d84f30a09bc526c646dbbbef88787b991feca8f Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 21 Aug 2009 09:43:04 +0000 Subject: 2009-08-21 Janus Weil PR fortran/41106 * primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION. (gfc_expr_attr): Use gfc_variable_attr for procedure pointer components. * resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure pointer components. * trans-expr.c (gfc_conv_component_ref): Ditto. (gfc_conv_variable): Ditto. (gfc_conv_procedure_call): Ditto. (gfc_trans_pointer_assignment): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-08-21 Janus Weil PR fortran/41106 * gfortran.dg/proc_ptr_23.f90: New. * gfortran.dg/proc_ptr_comp_15.f90: New. * gfortran.dg/proc_ptr_comp_16.f90: New. * gfortran.dg/proc_ptr_comp_17.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150987 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3782bb27e85..411e2c8d9dc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9476,7 +9476,7 @@ resolve_fl_derived (gfc_symbol *sym) if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/ + gfc_expr_replace_comp (c->ts.u.cl->length, c); } } else if (c->ts.interface->name[0] != '\0') @@ -9604,7 +9604,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CHARACTER) + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer) { if (c->ts.u.cl->length == NULL || (resolve_charlen (c->ts.u.cl) == FAILURE) -- cgit v1.2.1 From 0fd53ac9e79421de9b0d1f42521f15e9845983e7 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 25 Aug 2009 14:26:44 +0000 Subject: 2009-08-25 Janus Weil PR fortran/41139 * primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for calls to procedure pointer components, other references to procedure pointer components are EXPR_VARIABLE. * resolve.c (resolve_actual_arglist): Bugfix (there can be calls without actual arglist). * trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp', removed argument 'se' and made static. Avoid inserting a temporary variable for calling the PPC. (conv_function_val): Renamed gfc_get_proc_ptr_comp. (gfc_conv_procedure_call): Distinguish functions returning a procedure pointer from calls to a procedure pointer. Distinguish calls to procedure pointer components from procedure pointer components as actual arguments. * trans-stmt.h (gfc_get_proc_ptr_comp): Make it static. 2009-08-25 Janus Weil PR fortran/41139 * gfortran.dg/proc_ptr_25.f90: New. * gfortran.dg/proc_ptr_comp_18.f90: New. * gfortran.dg/proc_ptr_comp_19.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151081 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 411e2c8d9dc..3bc4c587da3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1279,9 +1279,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_is_proc_ptr_comp (e, &comp)) { e->ts = comp->ts; - if (e->value.compcall.actual == NULL) - e->expr_type = EXPR_VARIABLE; - else + if (e->expr_type == EXPR_PPC) { if (comp->as != NULL) e->rank = comp->as->rank; -- cgit v1.2.1 From 7d034542867cddd55dc133813dae02338fdb9cf2 Mon Sep 17 00:00:00 2001 From: domob Date: Thu, 27 Aug 2009 11:42:56 +0000 Subject: 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.h (gfc_expr): Optionally store base-object in compcall value and add a new flag to distinguish assign-calls generated. (gfc_find_typebound_proc): Add locus argument. (gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto. (gfc_extend_expr): Return if failure was by a real error. * interface.c (matching_typebound_op): New routine. (build_compcall_for_operator): New routine. (gfc_extend_expr): Handle type-bound operators, some clean-up and return if failure was by a real error or just by not finding an appropriate operator definition. (gfc_extend_assign): Handle type-bound assignments. * module.c (MOD_VERSION): Incremented. (mio_intrinsic_op): New routine. (mio_full_typebound_tree): New routine to make typebound-procedures IO code reusable for type-bound user operators. (mio_f2k_derived): IO of type-bound operators. * primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and pass locus to gfc_find_typebound_proc. * resolve.c (resolve_operator): Only output error about no matching interface if gfc_extend_expr did not already fail with an error. (extract_compcall_passed_object): Use specified base-object if present. (update_compcall_arglist): Handle ignore_pass field. (resolve_ordinary_assign): Update to handle extended code for type-bound assignments, too. (resolve_code): Handle EXEC_ASSIGN_CALL statement code. (resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc. (resolve_typebound_generic), (resolve_typebound_procedure): Ditto. (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto. (ensure_not_abstract_walker), (resolve_fl_derived): Ditto. (resolve_typebound_procedures): Remove not-implemented error. (resolve_typebound_call): Handle assign-call flag. * symbol.c (find_typebound_proc_uop): New argument to pass locus for error message about PRIVATE, verify that a found procedure is not marked as erraneous. (gfc_find_typebound_intrinsic_op): Ditto. (gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg. 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.dg/impure_assignment_1.f90: Change expected error message. * gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented error and fix problem with recursive assignment. * gfortran.dg/typebound_operator_2.f03: No not-implemented check. * gfortran.dg/typebound_operator_3.f03: New test. * gfortran.dg/typebound_operator_4.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151140 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 111 +++++++++++++++++++++++++++++--------------------- 1 file changed, 65 insertions(+), 46 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3bc4c587da3..e1c931ba0ff 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3508,8 +3508,14 @@ resolve_operator (gfc_expr *e) bad_op: - if (gfc_extend_expr (e) == SUCCESS) - return SUCCESS; + { + bool real_error; + if (gfc_extend_expr (e, &real_error) == SUCCESS) + return SUCCESS; + + if (real_error) + return FAILURE; + } if (dual_locus_error) gfc_error (msg, &op1->where, &op2->where); @@ -4685,10 +4691,15 @@ extract_compcall_passed_object (gfc_expr* e) gcc_assert (e->expr_type == EXPR_COMPCALL); - po = gfc_get_expr (); - po->expr_type = EXPR_VARIABLE; - po->symtree = e->symtree; - po->ref = gfc_copy_ref (e->ref); + if (e->value.compcall.base_object) + po = gfc_copy_expr (e->value.compcall.base_object); + else + { + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + } if (gfc_resolve_expr (po) == FAILURE) return NULL; @@ -4721,7 +4732,7 @@ update_compcall_arglist (gfc_expr* e) return FAILURE; } - if (tbp->nopass) + if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); return SUCCESS; @@ -4957,7 +4968,7 @@ resolve_typebound_call (gfc_code* c) c->ext.actual = newactual; c->symtree = target; - c->op = EXEC_CALL; + c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); gfc_free_expr (c->expr1); @@ -4983,6 +4994,9 @@ resolve_compcall (gfc_expr* e) return FAILURE; } + /* These must not be assign-calls! */ + gcc_assert (!e->value.compcall.assign); + if (check_typebound_baseobject (e) == FAILURE) return FAILURE; @@ -6909,24 +6923,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (gfc_extend_assign (code, ns) == SUCCESS) { - lhs = code->ext.actual->expr; - rhs = code->ext.actual->next->expr; - if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym)) + gfc_symbol* assign_proc; + gfc_expr** rhsptr; + + if (code->op == EXEC_ASSIGN_CALL) { - gfc_error ("Subroutine '%s' called instead of assignment at " - "%L must be PURE", code->symtree->n.sym->name, - &code->loc); - return rval; + lhs = code->ext.actual->expr; + rhsptr = &code->ext.actual->next->expr; + assign_proc = code->symtree->n.sym; + } + else + { + gfc_actual_arglist* args; + gfc_typebound_proc* tbp; + + gcc_assert (code->op == EXEC_COMPCALL); + + args = code->expr1->value.compcall.actual; + lhs = args->expr; + rhsptr = &args->next->expr; + + tbp = code->expr1->value.compcall.tbp; + gcc_assert (!tbp->is_generic); + assign_proc = tbp->u.specific->n.sym; } /* Make a temporary rhs when there is a default initializer and rhs is the same symbol as the lhs. */ - if (rhs->expr_type == EXPR_VARIABLE - && rhs->symtree->n.sym->ts.type == BT_DERIVED - && has_default_initializer (rhs->symtree->n.sym->ts.u.derived) - && (lhs->symtree->n.sym == rhs->symtree->n.sym)) - code->ext.actual->next->expr = gfc_get_parentheses (rhs); + if ((*rhsptr)->expr_type == EXPR_VARIABLE + && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED + && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) + && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) + *rhsptr = gfc_get_parentheses (*rhsptr); + resolve_code (code, ns); return true; } @@ -6935,8 +6965,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (rhs->is_boz && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", - &code->loc) == FAILURE) + "a DATA statement and outside INT/REAL/DBLE/CMPLX", + &code->loc) == FAILURE) return false; /* Handle the case of a BOZ literal on the RHS. */ @@ -6981,7 +7011,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) rlen = rhs->value.character.length; else if (rhs->ts.u.cl != NULL - && rhs->ts.u.cl->length != NULL + && rhs->ts.u.cl->length != NULL && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer); @@ -7115,6 +7145,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: + case EXEC_ASSIGN_CALL: break; case EXEC_ENTRY: @@ -8870,8 +8901,8 @@ resolve_tb_generic_targets (gfc_symbol* super_type, /* Look for an inherited specific binding. */ if (super_type) { - inherited = gfc_find_typebound_proc (super_type, NULL, - target_name, true); + inherited = gfc_find_typebound_proc (super_type, NULL, target_name, + true, NULL); if (inherited) { @@ -8952,7 +8983,8 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) if (super_type) { gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true); + overridden = gfc_find_typebound_proc (super_type, NULL, st->name, + true, NULL); if (overridden && overridden->n.tb) st->n.tb->overridden = overridden->n.tb; @@ -9006,7 +9038,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, super_type = gfc_get_derived_super_type (derived); if (super_type && super_type->f2k_derived) p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, - op, true); + op, true, NULL); else p->overridden = NULL; @@ -9021,10 +9053,10 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, target_proc = get_checked_tb_operator_target (target, p->where); if (!target_proc) - return FAILURE; + goto error; if (!gfc_check_operator_interface (target_proc, op, p->where)) - return FAILURE; + goto error; } return SUCCESS; @@ -9062,7 +9094,7 @@ resolve_typebound_user_op (gfc_symtree* stree) { gfc_symtree* overridden; overridden = gfc_find_typebound_user_op (super_type, NULL, - stree->name, true); + stree->name, true, NULL); if (overridden && overridden->n.tb) stree->n.tb->overridden = overridden->n.tb; @@ -9225,7 +9257,7 @@ resolve_typebound_procedure (gfc_symtree* stree) { gfc_symtree* overridden; overridden = gfc_find_typebound_proc (super_type, NULL, - stree->name, true); + stree->name, true, NULL); if (overridden && overridden->n.tb) stree->n.tb->overridden = overridden->n.tb; @@ -9265,7 +9297,6 @@ static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { int op; - bool found_op; if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; @@ -9277,7 +9308,6 @@ resolve_typebound_procedures (gfc_symbol* derived) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, &resolve_typebound_procedure); - found_op = (derived->f2k_derived->tb_uop_root != NULL); if (derived->f2k_derived->tb_uop_root) gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, &resolve_typebound_user_op); @@ -9288,17 +9318,6 @@ resolve_typebound_procedures (gfc_symbol* derived) if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op, p) == FAILURE) resolve_bindings_result = FAILURE; - if (p) - found_op = true; - } - - /* FIXME: Remove this (and found_op) once calls are fully implemented. */ - if (found_op) - { - gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's," - " they are not yet implemented.", - derived->name, &derived->declared_at); - resolve_bindings_result = FAILURE; } return resolve_bindings_result; @@ -9343,7 +9362,7 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) if (st->n.tb && st->n.tb->deferred) { gfc_symtree* overriding; - overriding = gfc_find_typebound_proc (sub, NULL, st->name, true); + overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); gcc_assert (overriding && overriding->n.tb); if (overriding->n.tb->deferred) { @@ -9594,7 +9613,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type - && gfc_find_typebound_proc (super_type, NULL, c->name, true)) + && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component '%s' of '%s' at %L has the same name as an" " inherited type-bound procedure", -- cgit v1.2.1 From 10e9d5ee9cdd7a24dead20d3db2702644e5b580f Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 27 Aug 2009 19:48:46 +0000 Subject: 2009-08-27 Janus Weil PR fortran/40869 * expr.c (gfc_check_pointer_assign): Enable interface check for pointer assignments involving procedure pointer components. * gfortran.h (gfc_compare_interfaces): Modified prototype. * interface.c (gfc_compare_interfaces): Add argument 'name2', to be used instead of s2->name. Don't rely on the proc_pointer attribute, but instead on the flags handed to this function. (check_interface1,compare_parameter): Add argument for gfc_compare_interfaces. * resolve.c (check_generic_tbp_ambiguity): Ditto. 2009-08-27 Janus Weil PR fortran/40869 * gfortran.dg/proc_ptr_comp_20.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151147 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e1c931ba0ff..f10a4123a6b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8851,7 +8851,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } /* Compare the interfaces. */ - if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0)) + if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0)) { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); -- cgit v1.2.1 From eb67c215519d8619b801c38ac575c38f8777f07b Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 31 Aug 2009 10:22:32 +0000 Subject: 2009-08-31 Janus Weil PR fortran/40996 * check.c (gfc_check_allocated): Implement allocatable scalars. * resolve.c (resolve_allocate_expr,resolve_fl_var_and_proc): Ditto. * trans-intrinsic.c (gfc_conv_allocated): Ditto. 2009-08-31 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_1.f90: New. * gfortran.dg/allocatable_scalar_2.f90: Renamed from finalize_9.f03. * gfortran.dg/finalize_9.f03: Renamed to allocatable_scalar_2.f90. * gfortran.dg/proc_ptr_comp_pass_4.f90: Modified. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151240 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f10a4123a6b..b665c354503 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5643,7 +5643,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) code->next = init_st; } - if (pointer && dimension == 0) + if (pointer || dimension == 0) return SUCCESS; /* Make sure the next-to-last reference node is an array specification. */ @@ -7955,11 +7955,14 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (sym->attr.allocatable) { if (sym->attr.dimension) - gfc_error ("Allocatable array '%s' at %L must have " - "a deferred shape", sym->name, &sym->declared_at); - else - gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE", - sym->name, &sym->declared_at); + { + gfc_error ("Allocatable array '%s' at %L must have " + "a deferred shape", sym->name, &sym->declared_at); + return FAILURE; + } + else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L " + "may not be ALLOCATABLE", sym->name, + &sym->declared_at) == FAILURE) return FAILURE; } -- cgit v1.2.1 From b6bbfb84bd98f3c2e451883e0c675d2ad1b8ed33 Mon Sep 17 00:00:00 2001 From: tkoenig Date: Mon, 7 Sep 2009 15:23:15 +0000 Subject: 2009-09-07 Thomas Koenig PR fortran/41197 * resolve_c (resolve_allocate_deallocate): Complain if stat or errmsg varaible is an array. 2009-09-07 Thomas Koenig PR fortran/41197 * gfortran.dg/allocate_alloc_opt_1.f90: Use scalar variables for stat and errmsg. * gfortran.dg/deallocate_alloc_opt_1.f90: Likewise. * gfortran.dg/allocate_stat_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151480 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b665c354503..fd365eb136a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5732,9 +5732,10 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Illegal stat-variable at %L for a PURE procedure", &stat->where); - if (stat->ts.type != BT_INTEGER - && !(stat->ref && (stat->ref->type == REF_ARRAY - || stat->ref->type == REF_COMPONENT))) + if ((stat->ts.type != BT_INTEGER + && !(stat->ref && (stat->ref->type == REF_ARRAY + || stat->ref->type == REF_COMPONENT))) + || stat->rank > 0) gfc_error ("Stat-variable at %L must be a scalar INTEGER " "variable", &stat->where); @@ -5759,10 +5760,11 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Illegal errmsg-variable at %L for a PURE procedure", &errmsg->where); - if (errmsg->ts.type != BT_CHARACTER - && !(errmsg->ref - && (errmsg->ref->type == REF_ARRAY - || errmsg->ref->type == REF_COMPONENT))) + if ((errmsg->ts.type != BT_CHARACTER + && !(errmsg->ref + && (errmsg->ref->type == REF_ARRAY + || errmsg->ref->type == REF_COMPONENT))) + || errmsg->rank > 0 ) gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER " "variable", &errmsg->where); -- cgit v1.2.1 From 56b411d93ee419b299aee7a9df3ce46ae2ecbed2 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 10 Sep 2009 22:47:03 +0000 Subject: 2009-09-11 Janus Weil PR fortran/41242 * resolve.c (resolve_ordinary_assign): Don't call resolve_code, to avoid that subsequent codes are resolved more than once. (resolve_code): Make sure that type-bound assignment operators are resolved correctly. 2009-09-11 Janus Weil PR fortran/41242 * gfortran.dg/proc_ptr_comp_21.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151620 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fd365eb136a..f208f406626 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6958,7 +6958,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) *rhsptr = gfc_get_parentheses (*rhsptr); - resolve_code (code, ns); return true; } @@ -7190,7 +7189,12 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; if (resolve_ordinary_assign (code, ns)) - goto call; + { + if (code->op == EXEC_COMPCALL) + goto compcall; + else + goto call; + } break; @@ -7241,6 +7245,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_COMPCALL: + compcall: resolve_typebound_call (code); break; -- cgit v1.2.1 From 6a7084d700f33c25ffdfe5e213b60f05785ba87c Mon Sep 17 00:00:00 2001 From: domob Date: Tue, 29 Sep 2009 07:42:42 +0000 Subject: 2009-09-29 Daniel Kraft PR fortran/39626 * gfortran.h (enum gfc_statement): Add ST_BLOCK and ST_END_BLOCK. (struct gfc_namespace): Convert flags to bit-fields and add flag `construct_entities' for use with BLOCK constructs. (enum gfc_exec_code): Add EXEC_BLOCK. (struct gfc_code): Add namespace field to union for EXEC_BLOCK. * match.h (gfc_match_block): New prototype. * parse.h (enum gfc_compile_state): Add COMP_BLOCK. * trans.h (gfc_process_block_locals): New prototype. (gfc_trans_deferred_vars): Made public, new prototype. * trans-stmt.h (gfc_trans_block_construct): New prototype. * decl.c (gfc_match_end): Handle END BLOCK correctly. (gfc_match_intent): Error if inside of BLOCK. (gfc_match_optional), (gfc_match_value): Ditto. * match.c (gfc_match_block): New routine. * parse.c (decode_statement): Handle BLOCK statement. (case_exec_markers): Add ST_BLOCK. (case_end): Add ST_END_BLOCK. (gfc_ascii_statement): Handle ST_BLOCK and ST_END_BLOCK. (parse_spec): Check for statements not allowed inside of BLOCK. (parse_block_construct): New routine. (parse_executable): Parse BLOCKs. (parse_progunit): Disallow CONTAINS in BLOCK constructs. * resolve.c (is_illegal_recursion): Find real container procedure and don't get confused by BLOCK constructs. (resolve_block_construct): New routine. (gfc_resolve_blocks), (resolve_code): Handle EXEC_BLOCK. * st.c (gfc_free_statement): Handle EXEC_BLOCK statements. * trans-decl.c (saved_local_decls): New static variable. (add_decl_as_local): New routine. (gfc_finish_var_decl): Add variable as local if inside BLOCK. (gfc_trans_deferred_vars): Make public. (gfc_process_block_locals): New routine. * trans-stmt.c (gfc_trans_block_construct): New routine. * trans.c (gfc_trans_code): Handle EXEC_BLOCK statements. 2009-09-29 Daniel Kraft PR fortran/39626 * gfortran.dg/block_1.f08: New test. * gfortran.dg/block_2.f08: New test. * gfortran.dg/block_3.f90: New test. * gfortran.dg/block_4.f08: New test. * gfortran.dg/block_5.f08: New test. * gfortran.dg/block_6.f08: New test. * gfortran.dg/block_7.f08: New test. * gfortran.dg/block_8.f08: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152266 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 56 +++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f208f406626..3eec50e5373 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1101,6 +1101,7 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) { gfc_symbol* proc_sym; gfc_symbol* context_proc; + gfc_namespace* real_context; gcc_assert (sym->attr.flavor == FL_PROCEDURE); @@ -1114,11 +1115,29 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) if (proc_sym->attr.recursive || gfc_option.flag_recursive) return false; - /* Find the context procdure's "real" symbol if it has entries. */ - context_proc = (context->entries ? context->entries->sym - : context->proc_name); - if (!context_proc) - return true; + /* Find the context procedure's "real" symbol if it has entries. + We look for a procedure symbol, so recurse on the parents if we don't + find one (like in case of a BLOCK construct). */ + for (real_context = context; ; real_context = real_context->parent) + { + /* We should find something, eventually! */ + gcc_assert (real_context); + + context_proc = (real_context->entries ? real_context->entries->sym + : real_context->proc_name); + + /* In some special cases, there may not be a proc_name, like for this + invalid code: + real(bad_kind()) function foo () ... + when checking the call to bad_kind (). + In these cases, we simply return here and assume that the + call is ok. */ + if (!context_proc) + return false; + + if (context_proc->attr.flavor != FL_LABEL) + break; + } /* A call from sym's body to itself is recursion, of course. */ if (context_proc == proc_sym) @@ -6838,7 +6857,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) } -/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and +/* Resolve a BLOCK construct statement. */ + +static void +resolve_block_construct (gfc_code* code) +{ + /* Eventually, we may want to do some checks here or handle special stuff. + But so far the only thing we can do is resolving the local namespace. */ + + gfc_resolve (code->ext.ns); +} + + +/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and DO code nodes. */ static void resolve_code (gfc_code *, gfc_namespace *); @@ -6875,6 +6906,10 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) resolve_branch (b->label1, b); break; + case EXEC_BLOCK: + resolve_block_construct (b); + break; + case EXEC_SELECT: case EXEC_FORALL: case EXEC_DO: @@ -6902,7 +6937,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) break; default: - gfc_internal_error ("resolve_block(): Bad block type"); + gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); } resolve_code (b->next, ns); @@ -7066,6 +7101,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) return false; } + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -7250,7 +7286,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_CALL_PPC: - resolve_ppc_call (code); + resolve_ppc_call (code); break; case EXEC_SELECT: @@ -7259,6 +7295,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_select (code); break; + case EXEC_BLOCK: + gfc_resolve (code->ext.ns); + break; + case EXEC_DO: if (code->ext.iterator != NULL) { -- cgit v1.2.1 From 1de1b1a9e40b5aa064d5e3d032dd43ce14f6d2ad Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 30 Sep 2009 19:55:45 +0000 Subject: fortran/ 2009-09-30 Janus Weil * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class container, if the contained type has it. Add an initializer for the class container. (add_init_expr_to_sym): Handle BT_CLASS. (vindex_counter): New counter for setting vindices. (gfc_match_derived_decl): Set vindex for all derived types, not only those which are being extended. * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class pointers. * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and GFC_ISYM_EXTENDS_TYPE_OF. (gfc_type_is_extensible): New prototype. * intrinsic.h (gfc_check_same_type_as): New prototype. * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. * primary.c (gfc_expr_attr): Handle CLASS-valued functions. * resolve.c (resolve_structure_cons): Handle BT_CLASS. (type_is_extensible): Make non-static and rename to 'gfc_type_is_extensible. (resolve_select_type): Renamed type_is_extensible. (resolve_class_assign): Handle NULL pointers. (resolve_fl_variable_derived): Renamed type_is_extensible. (resolve_fl_derived): Ditto. * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL initialization of class pointer components. (gfc_conv_structure): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): New functions. (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. 2009-09-30 Janus Weil * gfortran.h (type_selector, select_type_tmp): New global variables. * match.c (type_selector, select_type_tmp): New global variables, used for SELECT TYPE statements. (gfc_match_select_type): Better error handling. Remember selector. (gfc_match_type_is): Create temporary variable. * module.c (ab_attribute): New value 'AB_IS_CLASS'. (attr_bits): New string. (mio_symbol_attribute): Handle 'is_class'. * resolve.c (resolve_select_type): Insert pointer assignment statement, to assign temporary to selector. * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary in SELECT TYPE statements. 2009-09-30 Janus Weil * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. (gfc_expr_to_initialize): New prototype. * match.c (alloc_opt_list): Correctly check type compatibility. Renamed 'alloc_list'. (dealloc_opt_list): Renamed 'alloc_list'. * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' and make it non-static. (resolve_allocate_expr): Set vindex for CLASS variables correctly. Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. (resolve_allocate_deallocate): Renamed 'alloc_list'. (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change argument type. Adjust to work with ordinary assignments. (resolve_code): Call 'resolve_class_assign' for ordinary assignments. Renamed 'check_class_pointer_assign'. * st.c (gfc_free_statement): Renamed 'alloc_list'. * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle size determination and initialization of CLASS variables. Bugfix for ALLOCATE statements with default initialization and SOURCE block. (gfc_trans_deallocate): Renamed 'alloc_list'. 2009-09-30 Paul Thomas * trans-expr.c (gfc_conv_procedure_call): Convert a derived type actual to a class object if the formal argument is a class. 2009-09-30 Janus Weil PR fortran/40996 * decl.c (build_struct): Handle allocatable scalar components. * expr.c (gfc_add_component_ref): Correctly set typespec of expression, after inserting component reference. * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no variables are being used uninitialized. * primary.c (gfc_match_varspec): Handle CLASS array components. * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to EXEC_SELECT. * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): Handle allocatable scalar components. * trans-expr.c (gfc_conv_component_ref): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-09-30 Janus Weil * decl.c (encapsulate_class_symbol): Modify names of class container components by prefixing with '$'. (gfc_match_end): Handle COMP_SELECT_TYPE. * expr.c (gfc_add_component_ref): Modify names of class container components by prefixing with '$'. * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and ST_CLASS_IS. (gfc_case): New field 'ts'. (gfc_exec_op): Add EXEC_SELECT_TYPE. (gfc_type_is_extension_of): New prototype. * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): New prototypes. * match.c (match_derived_type_spec): New function. (match_type_spec): Use 'match_derived_type_spec'. (match_case_eos): Modify error message. (gfc_match_select_type): New function. (gfc_match_case): Modify error message. (gfc_match_type_is): New function. (gfc_match_class_is): Ditto. * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS statements. (next_statement): Handle ST_SELECT_TYPE. (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. (parse_select_type_block): New function. (parse_executable): Handle ST_SELECT_TYPE. * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of class container components by prefixing with '$'. (resolve_allocate_expr): Ditto. (resolve_select_type): New function. (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. (check_class_pointer_assign): Modify names of class container components by prefixing with '$'. (resolve_code): Ditto. * st.c (gfc_free_statement): Ditto. * symbol.c (gfc_type_is_extension_of): New function. (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. 2009-09-30 Janus Weil Paul Thomas * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. The second argument needs to be type-compatible with the first (not the other way around, which makes a difference for CLASS entities). * decl.c (encapsulate_class_symbol): New function. (build_sym,build_struct): Handle BT_CLASS, call 'encapsulate_class_symbol'. (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. (gfc_match_derived_decl): Set vindex; * expr.c (gfc_add_component_ref): New function. (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): Handle BT_CLASS. * dump-parse-tree.c (show_symbol): Print vindex. * gfortran.h (bt): New basic type BT_CLASS. (symbol_attribute): New field 'is_class'. (gfc_typespec): Remove field 'is_class'. (gfc_symbol): New field 'vindex'. (gfc_get_ultimate_derived_super_type): New prototype. (gfc_add_component_ref): Ditto. * interface.c (gfc_compare_derived_types): Pointer equality check moved here from gfc_compare_types. (gfc_compare_types): Handle BT_CLASS and use gfc_type_compatible. * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): Handle BT_CLASS. * misc.c (gfc_clear_ts): Removed is_class. (gfc_basic_typename,gfc_typename): Handle BT_CLASS. * module.c (bt_types,mio_typespec): Handle BT_CLASS. (mio_symbol): Handle vindex. * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. * resolve.c (find_array_spec,check_typebound_baseobject): Handle BT_CLASS. (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' inside 'gcc_assert'. (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. (check_class_pointer_assign): New function. (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, resolve_fl_variable): Handle BT_CLASS. (check_generic_tbp_ambiguity): Add special case. (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. * symbol.c (gfc_get_ultimate_derived_super_type): New function. (gfc_type_compatible): Handle BT_CLASS. * trans-expr.c (conv_parent_component_references): Handle CLASS containers. (gfc_conv_initializer): Handle BT_CLASS. * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): Handle BT_CLASS. testsuite/ 2009-09-30 Janus Weil * gfortran.dg/same_type_as_1.f03: New test. * gfortran.dg/same_type_as_2.f03: Ditto. 2009-09-30 Janus Weil * gfortran.dg/select_type_1.f03: Extended. * gfortran.dg/select_type_3.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/class_allocate_1.f03: New test. 2009-09-30 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_3.f90: New test. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/typebound_proc_5.f03: Changed error messages. 2009-09-30 Janus Weil * gfortran.dg/block_name_2.f90: Modified error message. * gfortran.dg/select_6.f90: Ditto. * gfortran.dg/select_type_1.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/allocate_derived_1.f90: Remove -w option. * gfortran.dg/class_1.f03: Ditto. * gfortran.dg/class_2.f03: Ditto. * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_call_9.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_operator_1.f03: Ditto. * gfortran.dg/typebound_operator_2.f03: Ditto. * gfortran.dg/typebound_operator_3.f03: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 372 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 303 insertions(+), 69 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3eec50e5373..445753eca82 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr) if (cons->expr->expr_type == EXPR_NULL && !(comp->attr.pointer || comp->attr.allocatable - || comp->attr.proc_pointer)) + || comp->attr.proc_pointer + || (comp->ts.type == BT_CLASS + && (comp->ts.u.derived->components->attr.pointer + || comp->ts.u.derived->components->attr.allocatable)))) { t = FAILURE; gfc_error ("The NULL in the derived type constructor at %L is " @@ -3931,7 +3934,10 @@ find_array_spec (gfc_expr *e) gfc_symbol *derived; gfc_ref *ref; - as = e->symtree->n.sym->as; + if (e->symtree->n.sym->ts.type == BT_CLASS) + as = e->symtree->n.sym->ts.u.derived->components->as; + else + as = e->symtree->n.sym->as; derived = NULL; for (ref = e->ref; ref; ref = ref->next) @@ -4844,7 +4850,7 @@ check_typebound_baseobject (gfc_expr* e) if (!base) return FAILURE; - gcc_assert (base->ts.type == BT_DERIVED); + gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); if (base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" @@ -5051,7 +5057,10 @@ static gfc_try resolve_ppc_call (gfc_code* c) { gfc_component *comp; - gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp)); + bool b; + + b = gfc_is_proc_ptr_comp (c->expr1, &comp); + gcc_assert (b); c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; @@ -5083,7 +5092,10 @@ static gfc_try resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; - gcc_assert (gfc_is_proc_ptr_comp (e, &comp)); + bool b; + + b = gfc_is_proc_ptr_comp (e, &comp); + gcc_assert (b); /* Convert to EXPR_FUNCTION. */ e->expr_type = EXPR_FUNCTION; @@ -5462,6 +5474,8 @@ resolve_deallocate_expr (gfc_expr *e) symbol_attribute attr; int allocatable, pointer, check_intent_in; gfc_ref *ref; + gfc_symbol *sym; + gfc_component *c; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -5472,8 +5486,18 @@ resolve_deallocate_expr (gfc_expr *e) if (e->expr_type != EXPR_VARIABLE) goto bad; - allocatable = e->symtree->n.sym->attr.allocatable; - pointer = e->symtree->n.sym->attr.pointer; + sym = e->symtree->n.sym; + + if (sym->ts.type == BT_CLASS) + { + allocatable = sym->ts.u.derived->components->attr.allocatable; + pointer = sym->ts.u.derived->components->attr.pointer; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + } for (ref = e->ref; ref; ref = ref->next) { if (pointer) @@ -5487,9 +5511,17 @@ resolve_deallocate_expr (gfc_expr *e) break; case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - pointer = ref->u.c.component->attr.pointer; + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = c->ts.u.derived->components->attr.allocatable; + pointer = c->ts.u.derived->components->attr.pointer; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + } break; case REF_SUBSTRING: @@ -5507,14 +5539,19 @@ resolve_deallocate_expr (gfc_expr *e) &e->where); } - if (check_intent_in - && e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L", - e->symtree->n.sym->name, &e->where); + sym->name, &e->where); return FAILURE; } + if (e->ts.type == BT_CLASS) + { + /* Only deallocate the DATA component. */ + gfc_add_component_ref (e, "$data"); + } + return SUCCESS; } @@ -5541,8 +5578,8 @@ gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) derived types with default initializers, and derived types with allocatable components that need nullification.) */ -static gfc_expr * -expr_to_initialize (gfc_expr *e) +gfc_expr * +gfc_expr_to_initialize (gfc_expr *e) { gfc_expr *result; gfc_ref *ref; @@ -5579,9 +5616,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_ref *ref, *ref2; gfc_array_ref *ar; gfc_code *init_st; - gfc_expr *init_e; gfc_symbol *sym; gfc_alloc *a; + gfc_component *c; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -5593,6 +5630,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) pointer, the next-to-last reference must be a pointer. */ ref2 = NULL; + if (e->symtree) + sym = e->symtree->n.sym; if (e->expr_type != EXPR_VARIABLE) { @@ -5603,9 +5642,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } else { - allocatable = e->symtree->n.sym->attr.allocatable; - pointer = e->symtree->n.sym->attr.pointer; - dimension = e->symtree->n.sym->attr.dimension; + if (sym->ts.type == BT_CLASS) + { + allocatable = sym->ts.u.derived->components->attr.allocatable; + pointer = sym->ts.u.derived->components->attr.pointer; + dimension = sym->ts.u.derived->components->attr.dimension; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + dimension = sym->attr.dimension; + } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) { @@ -5620,11 +5668,19 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) break; case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - - pointer = ref->u.c.component->attr.pointer; - dimension = ref->u.c.component->attr.dimension; + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = c->ts.u.derived->components->attr.allocatable; + pointer = c->ts.u.derived->components->attr.pointer; + dimension = c->ts.u.derived->components->attr.dimension; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + dimension = c->attr.dimension; + } break; case REF_SUBSTRING: @@ -5642,24 +5698,46 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } - if (check_intent_in - && e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", - e->symtree->n.sym->name, &e->where); + sym->name, &e->where); return FAILURE; } - /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts))) + if (e->ts.type == BT_CLASS) { + /* Initialize VINDEX for CLASS objects. */ init_st = gfc_get_code (); init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = expr_to_initialize (e); - init_st->expr2 = init_e; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->op = EXEC_ASSIGN; + gfc_add_component_ref (init_st->expr1, "$vindex"); + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + init_st->expr2 = gfc_copy_expr (code->expr3); + gfc_add_component_ref (init_st->expr2, "$vindex"); + } + else + { + /* vindex is fixed at compile time. */ + int vindex; + if (code->expr3) + vindex = code->expr3->ts.u.derived->vindex; + else if (code->ext.alloc.ts.type == BT_DERIVED) + vindex = code->ext.alloc.ts.u.derived->vindex; + else if (e->ts.type == BT_CLASS) + vindex = e->ts.u.derived->components->ts.u.derived->vindex; + else + vindex = e->ts.u.derived->vindex; + init_st->expr2 = gfc_int_expr (vindex); + } + init_st->expr2->where = init_st->expr1->where = init_st->loc; init_st->next = code->next; code->next = init_st; + /* Only allocate the DATA component. */ + gfc_add_component_ref (e, "$data"); } if (pointer || dimension == 0) @@ -5706,7 +5784,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) check_symbols: - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; @@ -5758,7 +5836,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Stat-variable at %L must be a scalar INTEGER " "variable", &stat->where); - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) gfc_error ("Stat-variable at %L shall not be %sd within " "the same %s statement", &stat->where, fcn, fcn); @@ -5787,7 +5865,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER " "variable", &errmsg->where); - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) gfc_error ("Errmsg-variable at %L shall not be %sd within " "the same %s statement", &errmsg->where, fcn, fcn); @@ -5795,7 +5873,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Check that an allocate-object appears only once in the statement. FIXME: Checking derived types is disabled. */ - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; if ((pe->ref && pe->ref->type != REF_COMPONENT) @@ -5815,12 +5893,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (strcmp (fcn, "ALLOCATE") == 0) { - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) resolve_allocate_expr (a->expr, code); } else { - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) resolve_deallocate_expr (a->expr); } } @@ -6346,6 +6424,116 @@ resolve_select (gfc_code *code) } +/* Check if a derived type is extensible. */ + +bool +gfc_type_is_extensible (gfc_symbol *sym) +{ + return !(sym->attr.is_bind_c || sym->attr.sequence); +} + + +/* Resolve a SELECT TYPE statement. */ + +static void +resolve_select_type (gfc_code *code) +{ + gfc_symbol *selector_type; + gfc_code *body, *new_st; + gfc_case *c, *default_case; + gfc_symtree *st; + char name[GFC_MAX_SYMBOL_LEN]; + + selector_type = code->expr1->ts.u.derived->components->ts.u.derived; + + /* Assume there is no DEFAULT case. */ + default_case = NULL; + + /* Loop over TYPE IS / CLASS IS cases. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.case_list; + + /* Check F03:C815. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !gfc_type_is_extensible (c->ts.u.derived)) + { + gfc_error ("Derived type '%s' at %L must be extensible", + c->ts.u.derived->name, &c->where); + continue; + } + + /* Check F03:C816. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !gfc_type_is_extension_of (selector_type, c->ts.u.derived)) + { + gfc_error ("Derived type '%s' at %L must be an extension of '%s'", + c->ts.u.derived->name, &c->where, selector_type->name); + continue; + } + + /* Intercept the DEFAULT case. */ + if (c->ts.type == BT_UNKNOWN) + { + /* Check F03:C818. */ + if (default_case != NULL) + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->where, &c->where); + else + default_case = c; + continue; + } + } + + /* Transform to EXEC_SELECT. */ + code->op = EXEC_SELECT; + gfc_add_component_ref (code->expr1, "$vindex"); + + /* Loop over TYPE IS / CLASS IS cases. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.case_list; + if (c->ts.type == BT_DERIVED) + c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex); + else if (c->ts.type == BT_CLASS) + /* Currently IS CLASS blocks are simply ignored. + TODO: Implement IS CLASS. */ + c->unreachable = 1; + + if (c->ts.type != BT_DERIVED) + continue; + /* Assign temporary to selector. */ + sprintf (name, "tmp$%s", c->ts.u.derived->name); + st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name); + new_st = gfc_get_code (); + new_st->op = EXEC_POINTER_ASSIGN; + new_st->expr1 = gfc_get_variable_expr (st); + new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree); + gfc_add_component_ref (new_st->expr2, "$data"); + new_st->next = body->next; + body->next = new_st; + } + + /* Eliminate dead blocks. */ + for (body = code; body && body->block; body = body->block) + { + if (body->block->ext.case_list->unreachable) + { + /* Cut the unreachable block from the code chain. */ + gfc_code *cd = body->block; + body->block = cd->block; + /* Kill the dead block, but not the blocks below it. */ + cd->block = NULL; + gfc_free_statements (cd); + } + } + + resolve_select (code); + +} + + /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components -- a derived type being transferred doesn't have private components, unless @@ -6911,6 +7099,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) break; case EXEC_SELECT: + case EXEC_SELECT_TYPE: case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: @@ -7102,6 +7291,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } +/* Check an assignment to a CLASS object (pointer or ordinary assignment). */ + +static void +resolve_class_assign (gfc_code *code) +{ + gfc_code *assign_code = gfc_get_code (); + + /* Insert an additional assignment which sets the vindex. */ + assign_code->next = code->next; + code->next = assign_code; + assign_code->op = EXEC_ASSIGN; + assign_code->expr1 = gfc_copy_expr (code->expr1); + gfc_add_component_ref (assign_code->expr1, "$vindex"); + if (code->expr2->ts.type == BT_DERIVED) + /* vindex is constant, determined at compile time. */ + assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); + else if (code->expr2->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + assign_code->expr2 = gfc_copy_expr (code->expr2); + gfc_add_component_ref (assign_code->expr2, "$vindex"); + } + else if (code->expr2->expr_type == EXPR_NULL) + assign_code->expr2 = gfc_int_expr (0); + else + gcc_unreachable (); + + /* Modify the actual pointer assignment. */ + gfc_add_component_ref (code->expr1, "$data"); + if (code->expr2->ts.type == BT_CLASS) + gfc_add_component_ref (code->expr2, "$data"); +} + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -7224,6 +7447,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; + if (code->expr1->ts.type == BT_CLASS) + resolve_class_assign (code); + if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) @@ -7252,7 +7478,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; + if (code->expr1->ts.type == BT_CLASS) + resolve_class_assign (code); + gfc_check_pointer_assign (code->expr1, code->expr2); + break; case EXEC_ARITHMETIC_IF: @@ -7295,6 +7525,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_select (code); break; + case EXEC_SELECT_TYPE: + resolve_select_type (code); + break; + case EXEC_BLOCK: gfc_resolve (code->ext.ns); break; @@ -8023,8 +8257,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } else { - if (!mp_flag && !sym->attr.allocatable - && !sym->attr.pointer && !sym->attr.dummy) + if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer + && !sym->attr.dummy && sym->ts.type != BT_CLASS) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); @@ -8035,22 +8269,13 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } -/* Check if a derived type is extensible. */ - -static bool -type_is_extensible (gfc_symbol *sym) -{ - return !(sym->attr.is_bind_c || sym->attr.sequence); -} - - /* Additional checks for symbols with flavor variable and derived type. To be called from resolve_fl_variable. */ static gfc_try resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { - gcc_assert (sym->ts.type == BT_DERIVED); + gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); /* Check to see if a derived type is blocked from being host associated by the presence of another class I symbol in the same @@ -8092,10 +8317,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) return FAILURE; } - if (sym->ts.is_class) + if (sym->ts.type == BT_CLASS) { /* C502. */ - if (!type_is_extensible (sym->ts.u.derived)) + if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", sym->ts.u.derived->name, sym->name, &sym->declared_at); @@ -8103,7 +8328,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) } /* C509. */ - if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer)) + if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer + || sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer)) { gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " "or pointer", sym->name, &sym->declared_at); @@ -8244,7 +8471,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) } no_init_error: - if (sym->ts.type == BT_DERIVED) + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) return resolve_fl_variable_derived (sym, no_init_flag); return SUCCESS; @@ -8890,6 +9117,9 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, sym1 = t1->specific->u.specific->n.sym; sym2 = t2->specific->u.specific->n.sym; + if (sym1 == sym2) + return SUCCESS; + /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ if (sym1->attr.subroutine != sym2->attr.subroutine || sym1->attr.function != sym2->attr.function) @@ -9283,21 +9513,22 @@ resolve_typebound_procedure (gfc_symtree* stree) /* Now check that the argument-type matches. */ gcc_assert (me_arg); - if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.u.derived != resolve_bindings_derived) + if (me_arg->ts.type != BT_CLASS) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" - " the derived-type '%s'", me_arg->name, proc->name, - me_arg->name, &where, resolve_bindings_derived->name); + gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + " at %L", proc->name, &where); goto error; } - if (!me_arg->ts.is_class) + if (me_arg->ts.u.derived->components->ts.u.derived + != resolve_bindings_derived) { - gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" - " at %L", proc->name, &where); + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" + " the derived-type '%s'", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); goto error; } + } /* If we are extending some type, check that we don't override a procedure @@ -9475,7 +9706,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !type_is_extensible (sym)) + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) { gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT", sym->name, &sym->declared_at); @@ -9611,8 +9842,10 @@ resolve_fl_derived (gfc_symbol *sym) /* Now check that the argument-type matches. */ gcc_assert (me_arg); - if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.u.derived != sym) + if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) + || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) + || (me_arg->ts.type == BT_CLASS + && me_arg->ts.u.derived->components->ts.u.derived != sym)) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived type '%s'", me_arg->name, c->name, @@ -9649,9 +9882,9 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (type_is_extensible (sym) && !me_arg->ts.is_class) + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" - " at %L", c->name, &c->loc); + " at %L", c->name, &c->loc); } @@ -9720,8 +9953,9 @@ resolve_fl_derived (gfc_symbol *sym) } /* C437. */ - if (c->ts.type == BT_DERIVED && c->ts.is_class - && !(c->attr.pointer || c->attr.allocatable)) + if (c->ts.type == BT_CLASS + && !(c->ts.u.derived->components->attr.pointer + || c->ts.u.derived->components->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); -- cgit v1.2.1 From 8337b32480c0319e23a26416249d275f89490ec7 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 30 Sep 2009 20:45:07 +0000 Subject: fortran/ 2009-09-30 Janus Weil * resolve.c (check_typebound_baseobject): Don't check for abstract types for CLASS. (resolve_class_assign): Adapt for RHS being a CLASS. * trans-intrinsic.c (gfc_conv_associated): Add component ref if expr is a CLASS. testsuite/ 2009-09-30 Tobias Burnus * gfortran.dg/select_type_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152346 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 49 +++++++++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 445753eca82..bb803b3475c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4851,7 +4851,8 @@ check_typebound_baseobject (gfc_expr* e) return FAILURE; gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); - if (base->ts.u.derived->attr.abstract) + + if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name); @@ -7298,30 +7299,34 @@ resolve_class_assign (gfc_code *code) { gfc_code *assign_code = gfc_get_code (); - /* Insert an additional assignment which sets the vindex. */ - assign_code->next = code->next; - code->next = assign_code; - assign_code->op = EXEC_ASSIGN; - assign_code->expr1 = gfc_copy_expr (code->expr1); - gfc_add_component_ref (assign_code->expr1, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->ts.type == BT_CLASS) - { - /* vindex must be determined at run time. */ - assign_code->expr2 = gfc_copy_expr (code->expr2); - gfc_add_component_ref (assign_code->expr2, "$vindex"); - } - else if (code->expr2->expr_type == EXPR_NULL) - assign_code->expr2 = gfc_int_expr (0); - else - gcc_unreachable (); + if (code->expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the vindex. */ + assign_code->next = code->next; + code->next = assign_code; + assign_code->op = EXEC_ASSIGN; + assign_code->expr1 = gfc_copy_expr (code->expr1); + gfc_add_component_ref (assign_code->expr1, "$vindex"); + if (code->expr2->ts.type == BT_DERIVED) + /* vindex is constant, determined at compile time. */ + assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); + else if (code->expr2->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + assign_code->expr2 = gfc_copy_expr (code->expr2); + gfc_add_component_ref (assign_code->expr2, "$vindex"); + } + else if (code->expr2->expr_type == EXPR_NULL) + assign_code->expr2 = gfc_int_expr (0); + else + gcc_unreachable (); + } /* Modify the actual pointer assignment. */ - gfc_add_component_ref (code->expr1, "$data"); if (code->expr2->ts.type == BT_CLASS) - gfc_add_component_ref (code->expr2, "$data"); + code->op = EXEC_ASSIGN; + else + gfc_add_component_ref (code->expr1, "$data"); } -- cgit v1.2.1 From d94c13853accd0d733620f127edb7eb40e4b70b5 Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 5 Oct 2009 18:19:55 +0000 Subject: 2009-10-05 Paul Thomas * trans-expr.c (select_class_proc): New function. (conv_function_val): Deal with class methods and call above. * symbol.c (gfc_type_compatible): Treat case where both ts1 and ts2 are BT_CLASS. gfortran.h : Add structure gfc_class_esym_list and include in the structure gfc_expr. * module.c (load_derived_extensions): New function. (read_module): Call above. (write_dt_extensions): New function. (write_derived_extensions): New function. (write_module): Use the above. * resolve.c (resolve_typebound_call): Add a function expression for class methods. This carries the chain of symbols for the dynamic dispatch in select_class_proc. (resolve_compcall): Add second, boolean argument to indicate if a function is being handled. (check_members): New function. (check_class_members): New function. (resolve_class_compcall): New function. (resolve_class_typebound_call): New function. (gfc_resolve_expr): Call above for component calls.. 2009-10-05 Paul Thomas * gfortran.dg/dynamic_dispatch_1.f90: New test. * gfortran.dg/dynamic_dispatch_2.f90: New test. * gfortran.dg/dynamic_dispatch_3.f90: New test. * gfortran.dg/module_md5_1.f90: Update md5 sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152463 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 232 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 224 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bb803b3475c..2f0972b04eb 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4997,28 +4997,42 @@ resolve_typebound_call (gfc_code* c) c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); + gfc_free_expr (c->expr1); - c->expr1 = NULL; + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_FUNCTION; + c->expr1->symtree = target; + c->expr1->where = c->loc; return resolve_call (c); } -/* Resolve a component-call expression. */ - +/* Resolve a component-call expression. This originally was intended + only to see functions. However, it is convenient to use it in + resolving subroutine class methods, since we do not have to add a + gfc_code each time. */ static gfc_try -resolve_compcall (gfc_expr* e) +resolve_compcall (gfc_expr* e, bool fcn) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a FUNCTION. */ - if (!e->value.compcall.tbp->function) + if (fcn && !e->value.compcall.tbp->function) { gfc_error ("'%s' at %L should be a FUNCTION", e->value.compcall.name, &e->where); return FAILURE; } + else if (!fcn && !e->value.compcall.tbp->subroutine) + { + /* To resolve class member calls, we borrow this bit + of code to select the specific procedures. */ + gfc_error ("'%s' at %L should be a SUBROUTINE", + e->value.compcall.name, &e->where); + return FAILURE; + } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); @@ -5043,12 +5057,207 @@ resolve_compcall (gfc_expr* e) e->value.function.actual = newactual; e->value.function.name = e->value.compcall.name; e->value.function.esym = target->n.sym; + e->value.function.class_esym = NULL; e->value.function.isym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; - return gfc_resolve_expr (e); + /* Resolution is not necessary if this is a class subroutine; this + function only has to identify the specific proc. Resolution of + the call will be done next in resolve_typebound_call. */ + return fcn ? gfc_resolve_expr (e) : SUCCESS; +} + + +/* Resolve a typebound call for the members in a class. This group of + functions implements dynamic dispatch in the provisional version + of f03 OOP. As soon as vtables are in place and contain pointers + to methods, this will no longer be necessary. */ +static gfc_expr *list_e; +static void check_class_members (gfc_symbol *); +static gfc_try class_try; +static bool fcn_flag; +static gfc_symbol *class_object; + + +static void +check_members (gfc_symbol *derived) +{ + if (derived->attr.flavor == FL_DERIVED) + check_class_members (derived); +} + + +static void +check_class_members (gfc_symbol *derived) +{ + gfc_symbol* tbp_sym; + gfc_expr *e; + gfc_symtree *tbp; + gfc_class_esym_list *etmp; + + e = gfc_copy_expr (list_e); + + tbp = gfc_find_typebound_proc (derived, &class_try, + e->value.compcall.name, + false, &e->where); + + if (tbp == NULL) + { + gfc_error ("no typebound available procedure named '%s' at %L", + e->value.compcall.name, &e->where); + return; + } + + if (tbp->n.tb->is_generic) + { + tbp_sym = NULL; + + /* If we have to match a passed class member, force the actual + expression to have the correct type. */ + if (!tbp->n.tb->nopass) + { + if (e->value.compcall.base_object == NULL) + e->value.compcall.base_object = + extract_compcall_passed_object (e); + + e->value.compcall.base_object->ts.type = BT_DERIVED; + e->value.compcall.base_object->ts.u.derived = derived; + } + } + else + tbp_sym = tbp->n.tb->u.specific->n.sym; + + e->value.compcall.tbp = tbp->n.tb; + e->value.compcall.name = tbp->name; + + /* Do the renaming, PASSing, generic => specific and other + good things for each class member. */ + class_try = (resolve_compcall (e, fcn_flag) == SUCCESS) + ? class_try : FAILURE; + + /* Now transfer the found symbol to the esym list. */ + if (class_try == SUCCESS) + { + etmp = list_e->value.function.class_esym; + list_e->value.function.class_esym + = gfc_get_class_esym_list(); + list_e->value.function.class_esym->next = etmp; + list_e->value.function.class_esym->derived = derived; + list_e->value.function.class_esym->class_object + = class_object; + list_e->value.function.class_esym->esym + = e->value.function.esym; + } + + gfc_free_expr (e); + + /* Burrow down into grandchildren types. */ + if (derived->f2k_derived) + gfc_traverse_ns (derived->f2k_derived, check_members); +} + + +/* Eliminate esym_lists where all the members point to the + typebound procedure of the declared type; ie. one where + type selection has no effect.. */ +static void +resolve_class_esym (gfc_expr *e) +{ + gfc_class_esym_list *p, *q; + bool empty = true; + + gcc_assert (e && e->expr_type == EXPR_FUNCTION); + + p = e->value.function.class_esym; + if (p == NULL) + return; + + for (; p; p = p->next) + empty = empty && (e->value.function.esym == p->esym); + + if (empty) + { + p = e->value.function.class_esym; + for (; p; p = q) + { + q = p->next; + gfc_free (p); + } + e->value.function.class_esym = NULL; + } +} + + +/* Resolve a CLASS typebound function, or 'method'. */ +static gfc_try +resolve_class_compcall (gfc_expr* e) +{ + gfc_symbol *derived; + + class_object = e->symtree->n.sym; + + /* Get the CLASS type. */ + derived = e->symtree->n.sym->ts.u.derived; + + /* Get the data component, which is of the declared type. */ + derived = derived->components->ts.u.derived; + + /* Resolve the function call for each member of the class. */ + class_try = SUCCESS; + fcn_flag = true; + list_e = gfc_copy_expr (e); + check_class_members (derived); + + class_try = (resolve_compcall (e, true) == SUCCESS) + ? class_try : FAILURE; + + /* Transfer the class list to the original expression. Note that + the class_esym list is cleaned up in trans-expr.c, as the calls + are translated. */ + e->value.function.class_esym = list_e->value.function.class_esym; + list_e->value.function.class_esym = NULL; + gfc_free_expr (list_e); + + resolve_class_esym (e); + + return class_try; +} + +/* Resolve a CLASS typebound subroutine, or 'method'. */ +static gfc_try +resolve_class_typebound_call (gfc_code *code) +{ + gfc_symbol *derived; + + class_object = code->expr1->symtree->n.sym; + + /* Get the CLASS type. */ + derived = code->expr1->symtree->n.sym->ts.u.derived; + + /* Get the data component, which is of the declared type. */ + derived = derived->components->ts.u.derived; + + class_try = SUCCESS; + fcn_flag = false; + list_e = gfc_copy_expr (code->expr1); + check_class_members (derived); + + class_try = (resolve_typebound_call (code) == SUCCESS) + ? class_try : FAILURE; + + /* Transfer the class list to the original expression. Note that + the class_esym list is cleaned up in trans-expr.c, as the calls + are translated. */ + code->expr1->value.function.class_esym + = list_e->value.function.class_esym; + list_e->value.function.class_esym = NULL; + gfc_free_expr (list_e); + + resolve_class_esym (code->expr1); + + return class_try; } @@ -5162,7 +5371,10 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_COMPCALL: - t = resolve_compcall (e); + if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + t = resolve_class_compcall (e); + else + t = resolve_compcall (e, true); break; case EXPR_SUBSTRING: @@ -7517,7 +7729,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_COMPCALL: compcall: - resolve_typebound_call (code); + if (code->expr1->symtree + && code->expr1->symtree->n.sym->ts.type == BT_CLASS) + resolve_class_typebound_call (code); + else + resolve_typebound_call (code); break; case EXEC_CALL_PPC: -- cgit v1.2.1 From fdc056ccb06cdb28d3907dfc7eda7b0e323e2dfa Mon Sep 17 00:00:00 2001 From: pault Date: Wed, 7 Oct 2009 05:17:29 +0000 Subject: 2009-10-07 Paul Thomas PR fortran/41613 * resolve.c (check_class_members): Reset compcall.assign. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152513 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2f0972b04eb..8acd58097b7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5132,6 +5132,11 @@ check_class_members (gfc_symbol *derived) e->value.compcall.tbp = tbp->n.tb; e->value.compcall.name = tbp->name; + /* Let the original expresssion catch the assertion in + resolve_compcall, since this flag does not appear to be reset or + copied in some systems. */ + e->value.compcall.assign = 0; + /* Do the renaming, PASSing, generic => specific and other good things for each class member. */ class_try = (resolve_compcall (e, fcn_flag) == SUCCESS) -- cgit v1.2.1 From cd62bad79a89b57a105448aba8130fdfb88c0382 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 7 Oct 2009 10:54:35 +0000 Subject: 2009-10-07 Janus Weil * expr.c (gfc_check_pointer_assign): Do the correct type checking when CLASS variables are involved. * match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE statements, and set up a local namespace for the SELECT TYPE block. * parse.h (gfc_build_block_ns): New prototype. * parse.c (parse_select_type_block): Return from local namespace to its parent after SELECT TYPE block. (gfc_build_block_ns): New function for setting up the local namespace for a BLOCK construct. (parse_block_construct): Use gfc_build_block_ns. * resolve.c (resolve_select_type): Insert assignment for the selector variable, in case an associate-name is given, and put the SELECT TYPE statement inside a BLOCK. (resolve_code): Call resolve_class_assign after checking the assignment. * symbol.c (gfc_find_sym_tree): Moved some code here from gfc_get_ha_sym_tree. (gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree. 2009-10-07 Janus Weil * gfortran.dg/same_type_as_2.f03: Modified (was illegal). * gfortran.dg/select_type_1.f03: Modified error message. * gfortran.dg/select_type_5.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152526 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 47 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8acd58097b7..4092891f2c9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6661,8 +6661,15 @@ resolve_select_type (gfc_code *code) gfc_case *c, *default_case; gfc_symtree *st; char name[GFC_MAX_SYMBOL_LEN]; + gfc_namespace *ns; + + ns = code->ext.ns; + gfc_resolve (ns); - selector_type = code->expr1->ts.u.derived->components->ts.u.derived; + if (code->expr2) + selector_type = code->expr2->ts.u.derived->components->ts.u.derived; + else + selector_type = code->expr1->ts.u.derived->components->ts.u.derived; /* Assume there is no DEFAULT case. */ default_case = NULL; @@ -6704,6 +6711,32 @@ resolve_select_type (gfc_code *code) } } + if (code->expr2) + { + /* Insert assignment for selector variable. */ + new_st = gfc_get_code (); + new_st->op = EXEC_ASSIGN; + new_st->expr1 = gfc_copy_expr (code->expr1); + new_st->expr2 = gfc_copy_expr (code->expr2); + ns->code = new_st; + } + + /* Put SELECT TYPE statement inside a BLOCK. */ + new_st = gfc_get_code (); + new_st->op = code->op; + new_st->expr1 = code->expr1; + new_st->expr2 = code->expr2; + new_st->block = code->block; + if (!ns->code) + ns->code = new_st; + else + ns->code->next = new_st; + code->op = EXEC_BLOCK; + code->expr1 = code->expr2 = NULL; + code->block = NULL; + + code = new_st; + /* Transform to EXEC_SELECT. */ code->op = EXEC_SELECT; gfc_add_component_ref (code->expr1, "$vindex"); @@ -6723,7 +6756,7 @@ resolve_select_type (gfc_code *code) continue; /* Assign temporary to selector. */ sprintf (name, "tmp$%s", c->ts.u.derived->name); - st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name); + st = gfc_find_symtree (ns->sym_root, name); new_st = gfc_get_code (); new_st->op = EXEC_POINTER_ASSIGN; new_st->expr1 = gfc_get_variable_expr (st); @@ -7669,9 +7702,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; - if (code->expr1->ts.type == BT_CLASS) - resolve_class_assign (code); - if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) @@ -7680,6 +7710,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) goto call; } + if (code->expr1->ts.type == BT_CLASS) + resolve_class_assign (code); + break; case EXEC_LABEL_ASSIGN: @@ -7700,11 +7733,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; + gfc_check_pointer_assign (code->expr1, code->expr2); + if (code->expr1->ts.type == BT_CLASS) resolve_class_assign (code); - gfc_check_pointer_assign (code->expr1, code->expr2); - break; case EXEC_ARITHMETIC_IF: -- cgit v1.2.1 From 2576a2df09ac57e77bc67714b51688c882f0ab35 Mon Sep 17 00:00:00 2001 From: domob Date: Wed, 7 Oct 2009 18:13:28 +0000 Subject: 2009-10-07 Daniel Kraft PR fortran/41615 * resolve.c (resolve_contained_fntype): Clarify error message for invalid assumed-length character result on module procedures. 2009-10-07 Daniel Kraft PR fortran/41615 * gfortran.dg/assumed_charlen_function_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152534 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4092891f2c9..1aee540969c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -367,15 +367,26 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type, lists the only ways a character length value of * can be used: dummy arguments of procedures, named constants, and function results - in external functions. Internal function results are not on that list; - ergo, not permitted. */ + in external functions. Internal function results and results of module + procedures are not on this list, ergo, not permitted. */ if (sym->result->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->result->ts.u.cl; if (!cl || !cl->length) - gfc_error ("Character-valued internal function '%s' at %L must " - "not be assumed length", sym->name, &sym->declared_at); + { + /* See if this is a module-procedure and adapt error message + accordingly. */ + bool module_proc; + gcc_assert (ns->parent && ns->parent->proc_name); + module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); + + gfc_error ("Character-valued %s '%s' at %L must not be" + " assumed length", + module_proc ? _("module procedure") + : _("internal function"), + sym->name, &sym->declared_at); + } } } -- cgit v1.2.1 From bb1fa9b5643837c0077d1c0fddfa94e9335b86a0 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 9 Oct 2009 20:34:35 +0000 Subject: 2009-10-09 Tobias Burnus PR fortran/41582 * decl.c (encapsulate_class_symbol): Save attr.abstract. * resolve.c (resolve_allocate_expr): Reject class allocate without typespec or source=. * trans-stmt.c (gfc_trans_allocate): Change gfc_warning into gfc_error for "not yet implemented". 2009-10-09 Tobias Burnus PR fortran/41582 * gfortran.dg/class_allocate_1.f03: Modify code such that it compiles with the gfc_warning->gfc_error change. * gfortran.dg/class_allocate_1.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152601 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1aee540969c..5ea41c9bdf8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5840,7 +5840,7 @@ gfc_expr_to_initialize (gfc_expr *e) static gfc_try resolve_allocate_expr (gfc_expr *e, gfc_code *code) { - int i, pointer, allocatable, dimension, check_intent_in; + int i, pointer, allocatable, dimension, check_intent_in, is_abstract; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; @@ -5862,6 +5862,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (e->symtree) sym = e->symtree->n.sym; + /* Check whether ultimate component is abstract and CLASS. */ + is_abstract = 0; + if (e->expr_type != EXPR_VARIABLE) { allocatable = 0; @@ -5876,6 +5879,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = sym->ts.u.derived->components->attr.allocatable; pointer = sym->ts.u.derived->components->attr.pointer; dimension = sym->ts.u.derived->components->attr.dimension; + is_abstract = sym->ts.u.derived->components->attr.abstract; } else { @@ -5903,12 +5907,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = c->ts.u.derived->components->attr.allocatable; pointer = c->ts.u.derived->components->attr.pointer; dimension = c->ts.u.derived->components->attr.dimension; + is_abstract = c->ts.u.derived->components->attr.abstract; } else { allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; + is_abstract = c->attr.abstract; } break; @@ -5927,6 +5933,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } + if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN) + { + gcc_assert (e->ts.type == BT_CLASS); + gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " + "type-spec or SOURCE=", sym->name, &e->where); + return FAILURE; + } + if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", -- cgit v1.2.1 From 39f3dea01a12406705751179d795b548b7393289 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 13 Oct 2009 16:12:24 +0000 Subject: 2009-10-13 Janus Weil PR fortran/41581 * decl.c (encapsulate_class_symbol): Add new component '$size'. * resolve.c (resolve_allocate_expr): Move CLASS handling to gfc_trans_allocate. (resolve_class_assign): Replaced by gfc_trans_class_assign. (resolve_code): Remove calls to resolve_class_assign. * trans.c (gfc_trans_code): Use new function gfc_trans_class_assign. * trans-expr.c (get_proc_ptr_comp): Fix a memory leak. (gfc_conv_procedure_call): For CLASS dummies, set the $size component. (gfc_trans_class_assign): New function, replacing resolve_class_assign. * trans-stmt.h (gfc_trans_class_assign): New prototype. * trans-stmt.c (gfc_trans_allocate): Use correct size when allocating CLASS variables. Do proper initialization. Move some code here from resolve_allocate_expr. 2009-10-13 Janus Weil PR fortran/41581 * gfortran.dg/class_allocate_2.f03: Modified. * gfortran.dg/class_allocate_3.f03: New test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152715 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 82 --------------------------------------------------- 1 file changed, 82 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5ea41c9bdf8..9444fd10205 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5844,7 +5844,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_code *init_st; gfc_symbol *sym; gfc_alloc *a; gfc_component *c; @@ -5948,41 +5947,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } - if (e->ts.type == BT_CLASS) - { - /* Initialize VINDEX for CLASS objects. */ - init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->op = EXEC_ASSIGN; - gfc_add_component_ref (init_st->expr1, "$vindex"); - if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* vindex must be determined at run time. */ - init_st->expr2 = gfc_copy_expr (code->expr3); - gfc_add_component_ref (init_st->expr2, "$vindex"); - } - else - { - /* vindex is fixed at compile time. */ - int vindex; - if (code->expr3) - vindex = code->expr3->ts.u.derived->vindex; - else if (code->ext.alloc.ts.type == BT_DERIVED) - vindex = code->ext.alloc.ts.u.derived->vindex; - else if (e->ts.type == BT_CLASS) - vindex = e->ts.u.derived->components->ts.u.derived->vindex; - else - vindex = e->ts.u.derived->vindex; - init_st->expr2 = gfc_int_expr (vindex); - } - init_st->expr2->where = init_st->expr1->where = init_st->loc; - init_st->next = code->next; - code->next = init_st; - /* Only allocate the DATA component. */ - gfc_add_component_ref (e, "$data"); - } - if (pointer || dimension == 0) return SUCCESS; @@ -7567,44 +7531,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } -/* Check an assignment to a CLASS object (pointer or ordinary assignment). */ - -static void -resolve_class_assign (gfc_code *code) -{ - gfc_code *assign_code = gfc_get_code (); - - if (code->expr2->ts.type != BT_CLASS) - { - /* Insert an additional assignment which sets the vindex. */ - assign_code->next = code->next; - code->next = assign_code; - assign_code->op = EXEC_ASSIGN; - assign_code->expr1 = gfc_copy_expr (code->expr1); - gfc_add_component_ref (assign_code->expr1, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->ts.type == BT_CLASS) - { - /* vindex must be determined at run time. */ - assign_code->expr2 = gfc_copy_expr (code->expr2); - gfc_add_component_ref (assign_code->expr2, "$vindex"); - } - else if (code->expr2->expr_type == EXPR_NULL) - assign_code->expr2 = gfc_int_expr (0); - else - gcc_unreachable (); - } - - /* Modify the actual pointer assignment. */ - if (code->expr2->ts.type == BT_CLASS) - code->op = EXEC_ASSIGN; - else - gfc_add_component_ref (code->expr1, "$data"); -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -7734,10 +7660,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) else goto call; } - - if (code->expr1->ts.type == BT_CLASS) - resolve_class_assign (code); - break; case EXEC_LABEL_ASSIGN: @@ -7759,10 +7681,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; gfc_check_pointer_assign (code->expr1, code->expr2); - - if (code->expr1->ts.type == BT_CLASS) - resolve_class_assign (code); - break; case EXEC_ARITHMETIC_IF: -- cgit v1.2.1 From f3f303c6a323d7f3e368018f5bb96950c107dada Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 16 Oct 2009 06:07:09 +0000 Subject: 2009-10-16 Paul Thomas PR fortran/41648 PR fortran/41656 * trans-expr.c (select_class_proc): Convert the expression for the vindex, carried on the first member of the esym list. * gfortran.h : Add the vindex field to the esym_list structure. and eliminate the class_object field. * resolve.c (check_class_members): Remove the setting of the class_object field. (vindex_expr): New function. (get_class_from_expr): New function. (resolve_class_compcall): Call the above to find the ultimate class or derived component. If derived, do not generate the esym list. Add and expression for the vindex to the esym list by calling the above. (resolve_class_typebound_call): The same. 2009-10-16 Paul Thomas PR fortran/41648 * gfortran.dg/dynamic_dispatch_4.f03 : New test. PR fortran/41656 * gfortran.dg/dynamic_dispatch_5.f03 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152890 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 127 +++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 115 insertions(+), 12 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9444fd10205..d0911b485ab 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5161,8 +5161,6 @@ check_class_members (gfc_symbol *derived) = gfc_get_class_esym_list(); list_e->value.function.class_esym->next = etmp; list_e->value.function.class_esym->derived = derived; - list_e->value.function.class_esym->class_object - = class_object; list_e->value.function.class_esym->esym = e->value.function.esym; } @@ -5206,19 +5204,101 @@ resolve_class_esym (gfc_expr *e) } +/* Generate an expression for the vindex, given the reference to + the class of the final expression (class_ref), the base of the + full reference list (new_ref), the declared type and the class + object (st). */ +static gfc_expr* +vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref, + gfc_symbol *declared, gfc_symtree *st) +{ + gfc_expr *vindex; + gfc_ref *ref; + + /* Build an expression for the correct vindex; ie. that of the last + CLASS reference. */ + ref = gfc_get_ref(); + ref->type = REF_COMPONENT; + ref->u.c.component = declared->components->next; + ref->u.c.sym = declared; + ref->next = NULL; + if (class_ref) + { + class_ref->next = ref; + } + else + { + gfc_free_ref_list (new_ref); + new_ref = ref; + } + vindex = gfc_get_expr (); + vindex->expr_type = EXPR_VARIABLE; + vindex->symtree = st; + vindex->symtree->n.sym->refs++; + vindex->ts = ref->u.c.component->ts; + vindex->ref = new_ref; + + return vindex; +} + + +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + *class_ref = NULL; + *new_ref = gfc_copy_ref (e->ref); + for (ref = *new_ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if (ref->u.c.component->ts.type == BT_CLASS + || ref->u.c.component->ts.type == BT_DERIVED) + { + declared = ref->u.c.component->ts.u.derived; + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Resolve a CLASS typebound function, or 'method'. */ static gfc_try resolve_class_compcall (gfc_expr* e) { - gfc_symbol *derived; + gfc_symbol *derived, *declared; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + + st = e->symtree; + class_object = st->n.sym; - class_object = e->symtree->n.sym; + /* Get the CLASS declared type. */ + declared = get_declared_from_expr (&class_ref, &new_ref, e); - /* Get the CLASS type. */ - derived = e->symtree->n.sym->ts.u.derived; + /* Weed out cases of the ultimate component being a derived type. */ + if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + { + gfc_free_ref_list (new_ref); + return resolve_compcall (e, true); + } /* Get the data component, which is of the declared type. */ - derived = derived->components->ts.u.derived; + derived = declared->components->ts.u.derived; /* Resolve the function call for each member of the class. */ class_try = SUCCESS; @@ -5238,6 +5318,12 @@ resolve_class_compcall (gfc_expr* e) resolve_class_esym (e); + /* More than one typebound procedure so transmit an expression for + the vindex as the selector. */ + if (e->value.function.class_esym != NULL) + e->value.function.class_esym->vindex + = vindex_expr (class_ref, new_ref, declared, st); + return class_try; } @@ -5245,15 +5331,26 @@ resolve_class_compcall (gfc_expr* e) static gfc_try resolve_class_typebound_call (gfc_code *code) { - gfc_symbol *derived; + gfc_symbol *derived, *declared; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + + st = code->expr1->symtree; + class_object = st->n.sym; - class_object = code->expr1->symtree->n.sym; + /* Get the CLASS declared type. */ + declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); - /* Get the CLASS type. */ - derived = code->expr1->symtree->n.sym->ts.u.derived; + /* Weed out cases of the ultimate component being a derived type. */ + if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + { + gfc_free_ref_list (new_ref); + return resolve_typebound_call (code); + } /* Get the data component, which is of the declared type. */ - derived = derived->components->ts.u.derived; + derived = declared->components->ts.u.derived; class_try = SUCCESS; fcn_flag = false; @@ -5273,6 +5370,12 @@ resolve_class_typebound_call (gfc_code *code) resolve_class_esym (code->expr1); + /* More than one typebound procedure so transmit an expression for + the vindex as the selector. */ + if (code->expr1->value.function.class_esym != NULL) + code->expr1->value.function.class_esym->vindex + = vindex_expr (class_ref, new_ref, declared, st); + return class_try; } -- cgit v1.2.1 From 0ed65c4e7ad8fa10688ee5cdc4d45190c4126257 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 16 Oct 2009 21:10:43 +0000 Subject: 2009-10-16 Janus Weil PR fortran/41719 * resolve.c (resolve_ordinary_assign): Reject intrinsic assignments to polymorphic variables. 2009-10-16 Janus Weil PR fortran/41719 * gfortran.dg/class_5.f03: New test case. * gfortran.dg/typebound_operator_2.f03: Fixing invalid test case. * gfortran.dg/typebound_operator_4.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152919 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d0911b485ab..d76c461d28a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7629,6 +7629,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } } + /* F03:7.4.1.2. */ + if (lhs->ts.type == BT_CLASS) + { + gfc_error ("Variable must not be polymorphic in assignment at %L", + &lhs->where); + return false; + } + gfc_check_assign (lhs, rhs, 1); return false; } -- cgit v1.2.1 From b3704193582f3a455ad91d1d20b99034ca9ddb02 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 17 Oct 2009 18:09:25 +0000 Subject: 2009-10-17 Janus Weil Paul Thomas PR fortran/41608 * decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type and empty type errors. * parse.c (gfc_build_block_ns): Only set recursive if parent ns has a proc_name. PR fortran/41629 PR fortran/41618 PR fortran/41587 * gfortran.h : Add class_ok bitfield to symbol_attr. * decl.c (build_sym): Set attr.class_ok if dummy, pointer or allocatable. (build_struct): Use gfc_try 't' to carry errors past the call to encapsulate_class_symbol. (attr_decl1): For a CLASS object, apply the new attribute to the data component. * match.c (gfc_match_select_type): Set attr.class_ok for an assigned selector. * resolve.c (resolve_fl_variable_derived): Check a CLASS object is dummy, pointer or allocatable by testing the class_ok and the use_assoc attribute. 2009-10-17 Janus Weil Paul Thomas PR fortran/41629 * gfortran.dg/class_6.f90: New test. PR fortran/41608 PR fortran/41587 * gfortran.dg/class_7.f90: New test. PR fortran/41618 * gfortran.dg/class_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152955 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d76c461d28a..285228c4405 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8641,9 +8641,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) } /* C509. */ - if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer - || sym->ts.u.derived->components->attr.allocatable - || sym->ts.u.derived->components->attr.pointer)) + /* Assume that use associated symbols were checked in the module ns. */ + if (!sym->attr.class_ok && !sym->attr.use_assoc) { gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " "or pointer", sym->name, &sym->declared_at); -- cgit v1.2.1 From 191c342b44c76bde838b8a78c4aec45b82f85a5e Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 20 Oct 2009 04:16:02 +0000 Subject: 2009-10-20 Paul Thomas PR fortran/41706 * resolve.c (resolve_arg_exprs): New function. (resolve_class_compcall): Call the above. (resolve_class_typebound_call): The same. 2009-10-20 Paul Thomas PR fortran/41706 * gfortran.dg/class_9 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153004 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 285228c4405..42b6e76fc3a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5275,6 +5275,22 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, } +/* Resolve the argument expressions so that any arguments expressions + that include class methods are resolved before the current call. + This is necessary because of the static variables used in CLASS + method resolution. */ +static void +resolve_arg_exprs (gfc_actual_arglist *arg) +{ + /* Resolve the actual arglist expressions. */ + for (; arg; arg = arg->next) + { + if (arg->expr) + gfc_resolve_expr (arg->expr); + } +} + + /* Resolve a CLASS typebound function, or 'method'. */ static gfc_try resolve_class_compcall (gfc_expr* e) @@ -5295,7 +5311,10 @@ resolve_class_compcall (gfc_expr* e) { gfc_free_ref_list (new_ref); return resolve_compcall (e, true); - } + } + + /* Resolve the argument expressions, */ + resolve_arg_exprs (e->value.function.actual); /* Get the data component, which is of the declared type. */ derived = declared->components->ts.u.derived; @@ -5349,6 +5368,9 @@ resolve_class_typebound_call (gfc_code *code) return resolve_typebound_call (code); } + /* Resolve the argument expressions, */ + resolve_arg_exprs (code->ext.actual); + /* Get the data component, which is of the declared type. */ derived = declared->components->ts.u.derived; -- cgit v1.2.1 From 54b4dfd0465faee2d21ea305c13f0f4b3175cb62 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 21 Oct 2009 08:56:56 +0000 Subject: 2009-10-21 Janus Weil PR fortran/41706 PR fortran/41766 * match.c (select_type_set_tmp): Set flavor for temporary. * resolve.c (resolve_class_typebound_call): Correctly resolve actual arguments. 2009-10-21 Janus Weil PR fortran/41706 PR fortran/41766 * gfortran.dg/class_9.f03: Extended test case. * gfortran.dg/select_type_7.f03: New test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153049 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 42b6e76fc3a..8e23308d5b2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5369,7 +5369,7 @@ resolve_class_typebound_call (gfc_code *code) } /* Resolve the argument expressions, */ - resolve_arg_exprs (code->ext.actual); + resolve_arg_exprs (code->expr1->value.compcall.actual); /* Get the data component, which is of the declared type. */ derived = declared->components->ts.u.derived; -- cgit v1.2.1 From f30e488d09d7e3a1055346d2e5b4b167959dbd63 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 22 Oct 2009 08:53:26 +0000 Subject: 2009-10-22 Janus Weil PR fortran/41781 * resolve.c (resolve_codes): Don't clear 'cs_base' for BLOCK constructs, to make sure labels are treated correctly. * symbol.c (gfc_get_st_label): Create labels in the right namespace. For BLOCK constructs go into the parent namespace. 2009-10-22 Janus Weil PR fortran/41781 * gfortran.dg/goto_8.f90: New test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153446 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8e23308d5b2..4c10a0cc1d6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12053,7 +12053,11 @@ resolve_codes (gfc_namespace *ns) resolve_codes (n); gfc_current_ns = ns; - cs_base = NULL; + + /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */ + if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)) + cs_base = NULL; + /* Set to an out of range value. */ current_entry_id = -1; -- cgit v1.2.1 From af6755713af2776da6dc1ebef06b7aaddcdcbbc2 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 23 Oct 2009 11:01:38 +0000 Subject: 2009-10-23 Janus Weil PR fortran/41758 * match.c (conformable_arrays): Move to resolve.c. (gfc_match_allocate): Don't resolve SOURCE expr yet, and move some checks to resolve_allocate_expr. * resolve.c (conformable_arrays): Moved here from match.c. (resolve_allocate_expr): Moved some checks here from gfc_match_allocate. (resolve_code): Resolve SOURCE tag for ALLOCATE expressions. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153494 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 82 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4c10a0cc1d6..b17e8fef182 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5958,6 +5958,58 @@ gfc_expr_to_initialize (gfc_expr *e) } +/* Used in resolve_allocate_expr to check that a allocation-object and + a source-expr are conformable. This does not catch all possible + cases; in particular a runtime checking is needed. */ + +static gfc_try +conformable_arrays (gfc_expr *e1, gfc_expr *e2) +{ + /* First compare rank. */ + if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + { + gfc_error ("Source-expr at %L must be scalar or have the " + "same rank as the allocate-object at %L", + &e1->where, &e2->where); + return FAILURE; + } + + if (e1->shape) + { + int i; + mpz_t s; + + mpz_init (s); + + for (i = 0; i < e1->rank; i++) + { + if (e2->ref->u.ar.end[i]) + { + mpz_set (s, e2->ref->u.ar.end[i]->value.integer); + mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_add_ui (s, s, 1); + } + else + { + mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + } + + if (mpz_cmp (e1->shape[i], s) != 0) + { + gfc_error ("Source-expr at %L and allocate-object at %L must " + "have the same shape", &e1->where, &e2->where); + mpz_clear (s); + return FAILURE; + } + } + + mpz_clear (s); + } + + return SUCCESS; +} + + /* Resolve the expression in an ALLOCATE statement, doing the additional checks to see whether the expression is OK or not. The expression must have a trailing array reference that gives the size of the array. */ @@ -6057,7 +6109,32 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } - if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN) + /* Some checks for the SOURCE tag. */ + if (code->expr3) + { + /* Check F03:C631. */ + if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) + { + gfc_error ("Type of entity at %L is type incompatible with " + "source-expr at %L", &e->where, &code->expr3->where); + return FAILURE; + } + + /* Check F03:C632 and restriction following Note 6.18. */ + if (code->expr3->rank > 0 + && conformable_arrays (code->expr3, e) == FAILURE) + return FAILURE; + + /* Check F03:C633. */ + if (code->expr3->ts.kind != e->ts.kind) + { + gfc_error ("The allocate-object at %L and the source-expr at %L " + "shall have the same kind type parameter", + &e->where, &code->expr3->where); + return FAILURE; + } + } + else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " @@ -7734,6 +7811,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; + if (code->op == EXEC_ALLOCATE + && gfc_resolve_expr (code->expr3) == FAILURE) + t = FAILURE; + switch (code->op) { case EXEC_NOP: -- cgit v1.2.1 From a42d6508794431705c5d4abfde69f7be291b2bc2 Mon Sep 17 00:00:00 2001 From: jb Date: Wed, 28 Oct 2009 23:25:08 +0000 Subject: PR fortran/41860 Treat vars as save with -fno-automatic git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153689 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b17e8fef182..5a5fcccc1f8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8630,7 +8630,8 @@ apply_default_init_local (gfc_symbol *sym) /* For saved variables, we don't want to add an initializer at function entry, so we just add a static initializer. */ - if (sym->attr.save || sym->ns->save_all) + if (sym->attr.save || sym->ns->save_all + || gfc_option.flag_max_stack_var_size == 0) { /* Don't clobber an existing initializer! */ gcc_assert (sym->value == NULL); -- cgit v1.2.1 From 449db53c97557c939e81061836e6b7fd3de4566d Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 4 Nov 2009 19:41:07 +0000 Subject: 2009-11-04 Tobias Burnus Janus Weil PR fortran/41556 PR fortran/41937 * interface.c (gfc_check_operator_interface): Handle CLASS arguments. * resolve.c (resolve_allocate_expr): Handle allocatable components of CLASS variables. 2009-11-04 Janus Weil PR fortran/41556 PR fortran/41937 * gfortran.dg/class_11.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153911 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5a5fcccc1f8..4a83f22dfd4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6198,7 +6198,7 @@ check_symbols: sym = a->expr->symtree->n.sym; /* TODO - check derived type components. */ - if (sym->ts.type == BT_DERIVED) + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) continue; if ((ar->start[i] != NULL -- cgit v1.2.1 From f3c5115b79b94223476d775218631703e1bc4045 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 5 Nov 2009 10:42:48 +0000 Subject: 2009-11-05 Janus Weil PR fortran/41556 PR fortran/41873 * resolve.c (resolve_function,resolve_call): Prevent abstract interfaces from being called, but allow deferred type-bound procedures with abstract interface. 2009-11-05 Janus Weil PR fortran/41556 PR fortran/41873 * gfortran.dg/interface_abstract_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153934 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4a83f22dfd4..a721d944b33 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2526,7 +2526,9 @@ resolve_function (gfc_expr *expr) return FAILURE; } - if (sym && sym->attr.abstract) + /* If this ia a deferred TBP with an abstract interface (which may + of course be referenced), expr->value.function.name will be set. */ + if (sym && sym->attr.abstract && !expr->value.function.name) { gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", sym->name, &expr->where); @@ -3138,6 +3140,15 @@ resolve_call (gfc_code *c) } } + /* If this ia a deferred TBP with an abstract interface + (which may of course be referenced), c->expr1 will be set. */ + if (csym && csym->attr.abstract && !c->expr1) + { + gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", + csym->name, &c->loc); + return FAILURE; + } + /* Subroutines without the RECURSIVE attribution are not allowed to * call themselves. */ if (csym && is_illegal_recursion (csym, gfc_current_ns)) -- cgit v1.2.1 From 60c65947efc899d2cf0adb8922c054ab4e5be3f3 Mon Sep 17 00:00:00 2001 From: kargl Date: Fri, 6 Nov 2009 23:47:51 +0000 Subject: 2009-11-06 Steven G. Kargl resolve.c (check_typebound_override): Remove duplicate "in" in error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153982 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a721d944b33..1cbe04a3a46 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9480,8 +9480,8 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) if (proc_pass_arg != argpos && old_pass_arg != argpos && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts)) { - gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in" - " in respect to the overridden procedure", + gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L " + "in respect to the overridden procedure", proc_formal->sym->name, proc->name, &where); return FAILURE; } -- cgit v1.2.1 From 595aea75a2e987e4b8986bead57f4a8d00254874 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sat, 7 Nov 2009 02:30:08 +0000 Subject: 2009-11-06 Jerry DeLisle * resolve.c (is_illegal_recursion): Return false if sym is program. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153988 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1cbe04a3a46..d9a53e2fa95 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1117,6 +1117,9 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) gfc_symbol* context_proc; gfc_namespace* real_context; + if (sym->attr.flavor == FL_PROGRAM) + return false; + gcc_assert (sym->attr.flavor == FL_PROCEDURE); /* If we've got an ENTRY, find real procedure. */ -- cgit v1.2.1 From 4d9b926d2288abbcd1c331385187e988a5b8377d Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 11 Nov 2009 22:37:31 +0000 Subject: 2009-11-11 Janus Weil PR fortran/41978 * resolve.c (resolve_ref): Take care of procedure pointer component references. 2009-11-11 Janus Weil PR fortran/41978 * gfortran.dg/proc_ptr_comp_22.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154107 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d9a53e2fa95..f3fce1b38ad 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4275,7 +4275,9 @@ resolve_ref (gfc_expr *expr) case REF_COMPONENT: if (current_part_dimension || seen_part_dimension) { - if (ref->u.c.component->attr.pointer) + /* F03:C614. */ + if (ref->u.c.component->attr.pointer + || ref->u.c.component->attr.proc_pointer) { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the POINTER " -- cgit v1.2.1 From 9d6ee0cd16019c6cabf3d1fa55dfa3315b0267b3 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sun, 22 Nov 2009 01:59:16 +0000 Subject: 2009-11-21 Jerry DeLisle * trans-const.c (gfc_conv_const): Fix typo in comment. Replace assert with error message if not constant. * resolve.c (next_data_value): Delete check for constant. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154418 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 --- 1 file changed, 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f3fce1b38ad..bd690a71f0e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11083,9 +11083,6 @@ next_data_value (void) { while (mpz_cmp_ui (values.left, 0) == 0) { - if (!gfc_is_constant_expr (values.vnode->expr)) - gfc_error ("non-constant DATA value at %L", - &values.vnode->expr->where); if (values.vnode->next == NULL) return FAILURE; -- cgit v1.2.1 From ffe221be5de13e10d034dfec9a01b44aa96ea8b3 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 24 Nov 2009 08:16:32 +0000 Subject: 2009-11-24 Janus Weil PR fortran/42045 * resolve.c (resolve_actual_arglist): Make sure procedure pointer actual arguments are resolved correctly. (resolve_function): An EXPR_FUNCTION which is a procedure pointer component, has already been resolved. (resolve_fl_derived): Procedure pointer components should not be implicitly typed. 2009-11-24 Janus Weil PR fortran/42045 * gfortran.dg/proc_ptr_comp_2.f90: Correct invalid test case. * gfortran.dg/proc_ptr_comp_3.f90: Extended test case. * gfortran.dg/proc_ptr_comp_24.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154492 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bd690a71f0e..740679edd2d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1321,6 +1321,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, e->rank = comp->as->rank; e->expr_type = EXPR_FUNCTION; } + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; goto argument_list; } @@ -2519,6 +2521,10 @@ resolve_function (gfc_expr *expr) if (expr->symtree) sym = expr->symtree->n.sym; + /* If this is a procedure pointer component, it has already been resolved. */ + if (gfc_is_proc_ptr_comp (expr, NULL)) + return SUCCESS; + if (sym && sym->attr.intrinsic && resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; @@ -10219,8 +10225,9 @@ resolve_fl_derived (gfc_symbol *sym) } else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { - c->ts = *gfc_get_default_type (c->name, NULL); - c->attr.implicit_type = 1; + /* Since PPCs are not implicitly typed, a PPC without an explicit + interface must be a subroutine. */ + gfc_add_subroutine (&c->attr, c->name, &c->loc); } /* Procedure pointer components: Check PASS arg. */ -- cgit v1.2.1 From 208593734c14b141f1a6f1a6524605e01f7f0b22 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 26 Nov 2009 19:01:02 +0000 Subject: 2009-11-26 Janus Weil PR fortran/42048 PR fortran/42167 * gfortran.h (gfc_is_function_return_value): New prototype. * match.c (gfc_match_call): Use new function 'gfc_is_function_return_value'. * primary.c (gfc_is_function_return_value): New function to check if a symbol is the return value of an encompassing function. (match_actual_arg,gfc_match_rvalue,match_variable): Use new function 'gfc_is_function_return_value'. * resolve.c (resolve_common_blocks,resolve_actual_arglist): Ditto. 2009-11-26 Janus Weil PR fortran/42048 PR fortran/42167 * gfortran.dg/select_type_10.f03: New test case. * gfortran.dg/typebound_call_11.f03: Extended test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154679 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 740679edd2d..5048f251528 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -776,7 +776,7 @@ resolve_common_blocks (gfc_symtree *common_root) gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); else if (sym->attr.result - ||(sym->attr.function && gfc_current_ns->proc_name == sym)) + || gfc_is_function_return_value (sym, gfc_current_ns)) gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " "that is also a function result", sym->name, &common_root->n.common->where); @@ -1400,10 +1400,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* If the symbol is the function that names the current (or parent) scope, then we really have a variable reference. */ - if (sym->attr.function && sym->result == sym - && (sym->ns->proc_name == sym - || (sym->ns->parent != NULL - && sym->ns->parent->proc_name == sym))) + if (gfc_is_function_return_value (sym, sym->ns)) goto got_variable; /* If all else fails, see if we have a specific intrinsic. */ -- cgit v1.2.1 From 66a56860076243903465dadec8482f55d32144dc Mon Sep 17 00:00:00 2001 From: jakub Date: Sat, 28 Nov 2009 12:13:21 +0000 Subject: * trans-common.c (create_common): Remove unused offset variable. * io.c (gfc_match_wait): Remove unused loc variable. * trans-openmp.c (gfc_trans_omp_clauses): Remove unused old_clauses variable. (gfc_trans_omp_do): Remove unused outermost variable. * iresolve.c (gfc_resolve_alarm_sub, gfc_resolve_fseek_sub): Remove unused status variable. * module.c (number_use_names): Remove unused c variable. (load_derived_extensions): Remove unused nuse variable. * trans-expr.c (gfc_conv_substring): Remove unused var variable. * trans-types.c (gfc_get_array_descr_info): Remove unused offset_off variable. * matchexp.c (match_primary): Remove unused where variable. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Remove unused cond2 variable. (gfc_conv_intrinsic_sizeof): Remove unused source variable. (gfc_conv_intrinsic_transfer): Remove unused stride variable. (gfc_conv_intrinsic_function): Remove unused isym variable. * arith.c (gfc_hollerith2real, gfc_hollerith2complex, gfc_hollerith2logical): Remove unused len variable. * parse.c (parse_derived): Remove unused derived_sym variable. * decl.c (variable_decl): Remove unused old_locus variable. * resolve.c (check_class_members): Remove unused tbp_sym variable. (resolve_ordinary_assign): Remove unused assign_proc variable. (resolve_equivalence): Remove unused value_name variable. * data.c (get_array_index): Remove unused re variable. * trans-array.c (gfc_conv_array_transpose): Remove unused src_info variable. (gfc_conv_resolve_dependencies): Remove unused aref and temp_dim variables. (gfc_conv_loop_setup): Remove unused dim and len variables. (gfc_walk_variable_expr): Remove unused head variable. * match.c (match_typebound_call): Remove unused var variable. * intrinsic.c (gfc_convert_chartype): Remove unused from_ts variable. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154722 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5048f251528..b6853129d59 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5122,7 +5122,6 @@ check_members (gfc_symbol *derived) static void check_class_members (gfc_symbol *derived) { - gfc_symbol* tbp_sym; gfc_expr *e; gfc_symtree *tbp; gfc_class_esym_list *etmp; @@ -5142,8 +5141,6 @@ check_class_members (gfc_symbol *derived) if (tbp->n.tb->is_generic) { - tbp_sym = NULL; - /* If we have to match a passed class member, force the actual expression to have the correct type. */ if (!tbp->n.tb->nopass) @@ -5156,8 +5153,6 @@ check_class_members (gfc_symbol *derived) e->value.compcall.base_object->ts.u.derived = derived; } } - else - tbp_sym = tbp->n.tb->u.specific->n.sym; e->value.compcall.tbp = tbp->n.tb; e->value.compcall.name = tbp->name; @@ -7610,14 +7605,12 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (gfc_extend_assign (code, ns) == SUCCESS) { - gfc_symbol* assign_proc; gfc_expr** rhsptr; if (code->op == EXEC_ASSIGN_CALL) { lhs = code->ext.actual->expr; rhsptr = &code->ext.actual->next->expr; - assign_proc = code->symtree->n.sym; } else { @@ -7632,7 +7625,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) tbp = code->expr1->value.compcall.tbp; gcc_assert (!tbp->is_generic); - assign_proc = tbp->u.specific->n.sym; } /* Make a temporary rhs when there is a default initializer @@ -11690,10 +11682,8 @@ resolve_equivalence (gfc_equiv *eq) seq_type eq_type, last_eq_type; gfc_typespec *last_ts; int object, cnt_protected; - const char *value_name; const char *msg; - value_name = NULL; last_ts = &eq->expr->symtree->n.sym->ts; first_sym = eq->expr->symtree->n.sym; -- cgit v1.2.1 From bdfbc762ef80b1196e214ed9c90e9f57a11e264b Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 30 Nov 2009 20:43:06 +0000 Subject: merge from fortran-dev branch: gcc/fortran/ 2009-11-30 Janus Weil PR fortran/42053 * resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks. 2009-11-30 Janus Weil PR fortran/41631 * decl.c (gfc_match_derived_decl): Set extension level. * gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit. * iresolve.c (gfc_resolve_extends_type_of): Return value of 'is_extension_of' has kind=4. * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary for CLASS IS blocks. * module.c (MOD_VERSION): Bump module version. (ab_attribute,attr_bits): Remove AB_EXTENSION. (mio_symbol_attribute): Handle expanded 'extension' field. * resolve.c (resolve_select_type): Implement CLASS IS blocks. (resolve_fl_variable_derived): Show correct type name. * symbol.c (gfc_build_class_symbol): Set extension level. 2009-11-30 Janus Weil * intrinsic.h (gfc_resolve_extends_type_of): Add prototype. * intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'. * iresolve.c (gfc_resolve_extends_type_of): New function, which replaces the call to EXTENDS_TYPE_OF by the library function 'is_extension_of' and modifies the arguments. * trans-intrinsic.c (gfc_conv_extends_type_of): Removed. (gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall. 2009-11-30 Paul Thomas Janus Weil * decl.c (encapsulate_class_symbol): Replaced by 'gfc_build_class_symbol'. (build_sym,build_struct): Call 'gfc_build_class_symbol'. (gfc_match_derived_decl): Replace vindex by hash_value. * dump-parse-tree.c (show_symbol): Replace vindex by hash_value. * gfortran.h (symbol_attribute): Add field 'vtab'. (gfc_symbol): Replace vindex by hash_value. (gfc_class_esym_list): Ditto. (gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab): New prototypes. * module.c (mio_symbol): Replace vindex by hash_value. * resolve.c (vindex_expr): Rename to 'hash_value_expr'. (resolve_class_compcall,resolve_class_typebound_call): Renamed 'vindex_expr'. (resolve_select_type): Replace $vindex by $vptr->$hash. * symbol.c (gfc_add_save): Handle vtab symbols. (gfc_type_compatible): Rewrite. (gfc_build_class_symbol): New function which replaces 'encapsulate_class_symbol'. (gfc_find_derived_vtab): New function to set up a vtab symbol for a derived type. * trans-decl.c (gfc_create_module_variable): Handle vtab symbols. * trans-expr.c (select_class_proc): Replace vindex by hash_value. (gfc_conv_derived_to_class): New function to construct a temporary CLASS variable from a derived type expression. (gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'. (gfc_conv_structure): Initialize the $extends and $size fields of vtab symbols. (gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size assignment. * trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by $vptr->$hash, and replace vindex by hash_value. * trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace $vindex by $vptr. Remove the $size assignment. * trans-types.c (gfc_get_derived_type): Make it non-static. gcc/testsuite/ 2009-11-30 Janus Weil PR fortran/42053 * gfortran.dg/select_type_9.f03: New. 2009-11-30 Janus Weil PR fortran/41631 * gfortran.dg/extends_type_of_1.f03: Fix invalid test case. * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum. * gfortran.dg/select_type_1.f03: Remove FIXMEs. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/select_type_8.f03: New test. 2009-11-30 Janus Weil * gfortran.dg/extends_type_of_1.f03: New test. * gfortran.dg/same_type_as_1.f03: Extended. 2009-11-30 Paul Thomas * gfortran.dg/class_4c.f03: Add dg-additional-sources. * gfortran.dg/class_4d.f03: Rename module. Cleanup modules. libgfortran/ 2009-11-30 Janus Weil * gfortran.map: Add _gfortran_is_extension_of. * Makefile.am: Add intrinsics/extends_type_of.c. * Makefile.in: Regenerated. * intrinsics/extends_type_of.c: New file. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154840 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 226 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 168 insertions(+), 58 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b6853129d59..bf705c6a09a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e) } -/* Generate an expression for the vindex, given the reference to +/* Generate an expression for the hash value, given the reference to the class of the final expression (class_ref), the base of the full reference list (new_ref), the declared type and the class object (st). */ static gfc_expr* -vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref, - gfc_symbol *declared, gfc_symtree *st) +hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st) { - gfc_expr *vindex; - gfc_ref *ref; + gfc_expr *hash_value; - /* Build an expression for the correct vindex; ie. that of the last + /* Build an expression for the correct hash_value; ie. that of the last CLASS reference. */ - ref = gfc_get_ref(); - ref->type = REF_COMPONENT; - ref->u.c.component = declared->components->next; - ref->u.c.sym = declared; - ref->next = NULL; if (class_ref) { - class_ref->next = ref; + class_ref->next = NULL; } else { gfc_free_ref_list (new_ref); - new_ref = ref; + new_ref = NULL; } - vindex = gfc_get_expr (); - vindex->expr_type = EXPR_VARIABLE; - vindex->symtree = st; - vindex->symtree->n.sym->refs++; - vindex->ts = ref->u.c.component->ts; - vindex->ref = new_ref; + hash_value = gfc_get_expr (); + hash_value->expr_type = EXPR_VARIABLE; + hash_value->symtree = st; + hash_value->symtree->n.sym->refs++; + hash_value->ref = new_ref; + gfc_add_component_ref (hash_value, "$vptr"); + gfc_add_component_ref (hash_value, "$hash"); - return vindex; + return hash_value; } @@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e) resolve_class_esym (e); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (e->value.function.class_esym != NULL) - e->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + e->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code) resolve_class_esym (code->expr1); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (code->expr1->value.function.class_esym != NULL) - code->expr1->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + code->expr1->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -6862,11 +6856,13 @@ static void resolve_select_type (gfc_code *code) { gfc_symbol *selector_type; - gfc_code *body, *new_st; - gfc_case *c, *default_case; + gfc_code *body, *new_st, *if_st, *tail; + gfc_code *class_is = NULL, *default_case = NULL; + gfc_case *c; gfc_symtree *st; char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; + int error = 0; ns = code->ext.ns; gfc_resolve (ns); @@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code) else selector_type = code->expr1->ts.u.derived->components->ts.u.derived; - /* Assume there is no DEFAULT case. */ - default_case = NULL; - /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { @@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be extensible", c->ts.u.derived->name, &c->where); + error++; continue; } @@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be an extension of '%s'", c->ts.u.derived->name, &c->where, selector_type->name); + error++; continue; } @@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code) if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ - if (default_case != NULL) - gfc_error ("The DEFAULT CASE at %L cannot be followed " - "by a second DEFAULT CASE at %L", - &default_case->where, &c->where); + if (default_case) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->ext.case_list->where, &c->where); + error++; + continue; + } else - default_case = c; - continue; + default_case = body; } } + + if (error>0) + return; if (code->expr2) { @@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code) /* Transform to EXEC_SELECT. */ code->op = EXEC_SELECT; - gfc_add_component_ref (code->expr1, "$vindex"); + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, "$hash"); /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { c = body->ext.case_list; + if (c->ts.type == BT_DERIVED) - c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex); - else if (c->ts.type == BT_CLASS) - /* Currently IS CLASS blocks are simply ignored. - TODO: Implement IS CLASS. */ - c->unreachable = 1; - - if (c->ts.type != BT_DERIVED) + c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value); + else if (c->ts.type == BT_UNKNOWN) continue; + /* Assign temporary to selector. */ - sprintf (name, "tmp$%s", c->ts.u.derived->name); + if (c->ts.type == BT_CLASS) + sprintf (name, "tmp$class$%s", c->ts.u.derived->name); + else + sprintf (name, "tmp$type$%s", c->ts.u.derived->name); st = gfc_find_symtree (ns->sym_root, name); new_st = gfc_get_code (); - new_st->op = EXEC_POINTER_ASSIGN; new_st->expr1 = gfc_get_variable_expr (st); new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree); - gfc_add_component_ref (new_st->expr2, "$data"); + if (c->ts.type == BT_DERIVED) + { + new_st->op = EXEC_POINTER_ASSIGN; + gfc_add_component_ref (new_st->expr2, "$data"); + } + else + new_st->op = EXEC_POINTER_ASSIGN; new_st->next = body->next; body->next = new_st; } + + /* Take out CLASS IS cases for separate treatment. */ + body = code; + while (body && body->block) + { + if (body->block->ext.case_list->ts.type == BT_CLASS) + { + /* Add to class_is list. */ + if (class_is == NULL) + { + class_is = body->block; + tail = class_is; + } + else + { + for (tail = class_is; tail->block; tail = tail->block) ; + tail->block = body->block; + tail = tail->block; + } + /* Remove from EXEC_SELECT list. */ + body->block = body->block->block; + tail->block = NULL; + } + else + body = body->block; + } - /* Eliminate dead blocks. */ - for (body = code; body && body->block; body = body->block) + if (class_is) { - if (body->block->ext.case_list->unreachable) + gfc_symbol *vtab; + + if (!default_case) + { + /* Add a default case to hold the CLASS IS cases. */ + for (tail = code; tail->block; tail = tail->block) ; + tail->block = gfc_get_code (); + tail = tail->block; + tail->op = EXEC_SELECT_TYPE; + tail->ext.case_list = gfc_get_case (); + tail->ext.case_list->ts.type = BT_UNKNOWN; + tail->next = NULL; + default_case = tail; + } + + /* More than one CLASS IS block? */ + if (class_is->block) { - /* Cut the unreachable block from the code chain. */ - gfc_code *cd = body->block; - body->block = cd->block; - /* Kill the dead block, but not the blocks below it. */ - cd->block = NULL; - gfc_free_statements (cd); + gfc_code **c1,*c2; + bool swapped; + /* Sort CLASS IS blocks by extension level. */ + do + { + swapped = false; + for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) + { + c2 = (*c1)->block; + /* F03:C817 (check for doubles). */ + if ((*c1)->ext.case_list->ts.u.derived->hash_value + == c2->ext.case_list->ts.u.derived->hash_value) + { + gfc_error ("Double CLASS IS block in SELECT TYPE " + "statement at %L", &c2->ext.case_list->where); + return; + } + if ((*c1)->ext.case_list->ts.u.derived->attr.extension + < c2->ext.case_list->ts.u.derived->attr.extension) + { + /* Swap. */ + (*c1)->block = c2->block; + c2->block = *c1; + *c1 = c2; + swapped = true; + } + } + } + while (swapped); } + + /* Generate IF chain. */ + if_st = gfc_get_code (); + if_st->op = EXEC_IF; + new_st = if_st; + for (body = class_is; body; body = body->block) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + /* Set up IF condition: Call _gfortran_is_extension_of. */ + new_st->expr1 = gfc_get_expr (); + new_st->expr1->expr_type = EXPR_FUNCTION; + new_st->expr1->ts.type = BT_LOGICAL; + new_st->expr1->ts.kind = 4; + new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); + new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); + new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; + /* Set up arguments. */ + new_st->expr1->value.function.actual = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); + gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); + new_st->next = body->next; + } + if (default_case->next) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + new_st->next = default_case->next; + } + + /* Replace CLASS DEFAULT code by the IF chain. */ + default_case->next = if_st; } resolve_select (code); @@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->name, sym->name, &sym->declared_at); + sym->ts.u.derived->components->ts.u.derived->name, + sym->name, &sym->declared_at); return FAILURE; } -- cgit v1.2.1 From 0f77e4b8530980a42d981b38f6295a71ae02bc74 Mon Sep 17 00:00:00 2001 From: ghazi Date: Mon, 7 Dec 2009 15:32:43 +0000 Subject: PR other/40302 * arith.c: Remove HAVE_mpc* checks throughout. * expr.c: Likewise. * gfortran.h: Likewise. * resolve.c: Likewise. * simplify.c: Likewise. * target-memory.c: Likewise. * target-memory.h: Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155043 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bf705c6a09a..6f6cb781606 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8649,12 +8649,7 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_init2 (init_expr->value.complex, mpfr_get_default_prec()); -#else - mpfr_init (init_expr->value.complex.r); - mpfr_init (init_expr->value.complex.i); -#endif switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -8676,12 +8671,7 @@ build_default_init_expr (gfc_symbol *sym) break; case GFC_INIT_REAL_ZERO: -#ifdef HAVE_mpc mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); -#else - mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE); - mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE); -#endif break; default: -- cgit v1.2.1 From 4b68c8f791fda8f94422fbeadf6b3490e90bcd23 Mon Sep 17 00:00:00 2001 From: domob Date: Tue, 8 Dec 2009 11:39:20 +0000 Subject: 2008-12-08 Daniel Kraft PR fortran/41177 * gfortran.dg/typebound_proc_4.f03: Remove check for wrong error. * gfortran.dg/typebound_proc_13.f03: New test. 2008-12-08 Daniel Kraft PR fortran/41177 * gfortran.h (struct symbol_attribute): New flag `class_pointer'. * symbol.c (gfc_build_class_symbol): Set the new flag. * resolve.c (update_compcall_arglist): Remove wrong check for non-scalar base-object. (check_typebound_baseobject): Add the correct version here as well as some 'not implemented' message check in the old case. (resolve_typebound_procedure): Check that the passed-object dummy argument is scalar, non-pointer and non-allocatable as it should be. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155086 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 49 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6f6cb781606..8d2be53b2cd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4781,12 +4781,6 @@ update_compcall_arglist (gfc_expr* e) if (!po) return FAILURE; - if (po->rank > 0) - { - gfc_error ("Passed-object at %L must be scalar", &e->where); - return FAILURE; - } - if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); @@ -4889,6 +4883,22 @@ check_typebound_baseobject (gfc_expr* e) return FAILURE; } + /* If the procedure called is NOPASS, the base object must be scalar. */ + if (e->value.compcall.tbp->nopass && base->rank > 0) + { + gfc_error ("Base object for NOPASS type-bound procedure call at %L must" + " be scalar", &e->where); + return FAILURE; + } + + /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */ + if (base->rank > 0) + { + gfc_error ("Non-scalar base object at %L currently not implemented", + &e->where); + return FAILURE; + } + return SUCCESS; } @@ -10038,8 +10048,11 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg = proc->formal->sym; } - /* Now check that the argument-type matches. */ + /* Now check that the argument-type matches and the passed-object + dummy argument is generally fine. */ + gcc_assert (me_arg); + if (me_arg->ts.type != BT_CLASS) { gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" @@ -10055,7 +10068,27 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg->name, &where, resolve_bindings_derived->name); goto error; } - + + gcc_assert (me_arg->ts.type == BT_CLASS); + if (me_arg->ts.u.derived->components->as + && me_arg->ts.u.derived->components->as->rank > 0) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must be" + " scalar", proc->name, &where); + goto error; + } + if (me_arg->ts.u.derived->components->attr.allocatable) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must not" + " be ALLOCATABLE", proc->name, &where); + goto error; + } + if (me_arg->ts.u.derived->components->attr.class_pointer) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must not" + " be POINTER", proc->name, &where); + goto error; + } } /* If we are extending some type, check that we don't override a procedure -- cgit v1.2.1 From 8c2c51e82e7f9bab7ba3eb60b1dc5a7bfbb12673 Mon Sep 17 00:00:00 2001 From: dfranke Date: Fri, 11 Dec 2009 21:08:39 +0000 Subject: 2009-12-11 Daniel Franke PR fortran/40290 * expr.c (gfc_type_convert_binary): Added warn-on-conversion flag, passed on to gfc_convert_type_warn() instead of gfc_convert_type(); enabled warnings on all callers but ... * arith.c (eval_intrinsic): Disabled warnings on implicit type conversion. * gfortran.h gfc_type_convert_binary): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155179 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8d2be53b2cd..00bd4413529 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3320,7 +3320,7 @@ resolve_operator (gfc_expr *e) case INTRINSIC_POWER: if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { - gfc_type_convert_binary (e); + gfc_type_convert_binary (e, 1); break; } @@ -3407,7 +3407,7 @@ resolve_operator (gfc_expr *e) if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { - gfc_type_convert_binary (e); + gfc_type_convert_binary (e, 1); e->ts.type = BT_LOGICAL; e->ts.kind = gfc_default_logical_kind; -- cgit v1.2.1 From f5daae0b62b46cedc277548591a8fc28bf4637b2 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 15 Dec 2009 08:37:41 +0000 Subject: 2009-12-15 Tobias Burnus Daniel Franke PR fortran/41235 * resolve.c (resolve_global_procedure): Add check for presence of an explicit interface for nonconstant, nonassumed character-length functions. (resolve_fl_procedure): Remove check for nonconstant character-length functions. 2009-12-15 Tobias Burnus PR fortran/41235 * auto_char_len_1.f90: New test. * auto_char_len_2.f90: New test. * auto_char_len_4.f90: Correct test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155247 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 00bd4413529..78b0a7850d6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1830,6 +1830,21 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_error ("The reference to function '%s' at %L either needs an " "explicit INTERFACE or the rank is incorrect", sym->name, where); + + /* Non-assumed length character functions. */ + if (sym->attr.function && sym->ts.type == BT_CHARACTER + && gsym->ns->proc_name->ts.u.cl->length != NULL) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Nonconstant character-length function '%s' at %L " + "must have an explicit interface", sym->name, + &sym->declared_at); + } + } if (gfc_option.flag_whole_file == 1 || ((gfc_option.warn_std & GFC_STD_LEGACY) @@ -9038,23 +9053,12 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && resolve_charlen (cl) == FAILURE) return FAILURE; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + && sym->attr.proc == PROC_ST_FUNCTION) { - if (sym->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Character-valued statement function '%s' at %L must " - "have constant length", sym->name, &sym->declared_at); - return FAILURE; - } - - if (sym->attr.external && sym->formal == NULL - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Automatic character length function '%s' at %L must " - "have an explicit interface", sym->name, - &sym->declared_at); - return FAILURE; - } + gfc_error ("Character-valued statement function '%s' at %L must " + "have constant length", sym->name, &sym->declared_at); + return FAILURE; } } -- cgit v1.2.1 From 738928bee1b9d374e8d3db6508a3975867771734 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 8 Jan 2010 09:23:26 +0000 Subject: 2010-01-08 Tobias Burnus Date: Sat, 9 Jan 2010 09:11:53 +0000 Subject: 2010-01-09 Tobias Burnus PR fortran/41298 * trans-expr.c (gfc_trans_structure_assign): Handle c_null_(fun)ptr. * symbol.c (gen_special_c_interop_ptr): Add NULL_EXPR to the constructor for c_null_(fun)ptr. * resolve.c (resolve_structure_cons): Add special case for c_null_(fun)ptr. 2010-01-09 Tobias Burnus PR fortran/41298 * gfortran.dg/c_ptr_tests_14.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155755 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0378d4fa14a..8e8de8d5923 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1,5 +1,5 @@ /* Perform type resolution on the various structures. - Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -842,13 +842,20 @@ resolve_structure_cons (gfc_expr *expr) /* See if the user is trying to invoke a structure constructor for one of the iso_c_binding derived types. */ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived - && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL) + && expr->ts.u.derived->ts.is_iso_c && cons + && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL)) { gfc_error ("Components of structure constructor '%s' at %L are PRIVATE", expr->ts.u.derived->name, &(expr->where)); return FAILURE; } + /* Return if structure constructor is c_null_(fun)prt. */ + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived + && expr->ts.u.derived->ts.is_iso_c && cons + && cons->expr && cons->expr->expr_type == EXPR_NULL) + return SUCCESS; + for (; comp; comp = comp->next, cons = cons->next) { int rank; -- cgit v1.2.1 From c315461d1a22ed500bc4d1f2897dddcb77a9e011 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sat, 9 Jan 2010 17:47:04 +0000 Subject: 2010-01-09 Jerry DeLisle PR fortran/20923 PR fortran/32489 * trans-array.c (gfc_conv_array_initializer): Change call to gfc_error_now to call to gfc_fatal_error. * array.c (count_elements): Whitespace. (extract_element): Whitespace. (is_constant_element): Changed name from constant_element. (gfc_constant_ac): Only use expand_construuctor for expression types of EXPR_ARRAY. If expression type is EXPR_CONSTANT, no need to call gfc_is_constant_expr. * expr.c (gfc_reduce_init_expr): Adjust conditionals and delete error message. * resolve.c (gfc_is_expandable_expr): New function that determiners if array expressions should have their constructors expanded. (gfc_resolve_expr): Use new function to determine whether or not to call gfc_expand_constructor. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155769 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8e8de8d5923..7321c0dd767 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5516,6 +5516,32 @@ resolve_expr_ppc (gfc_expr* e) } +static bool +gfc_is_expandable_expr (gfc_expr *e) +{ + gfc_constructor *con; + + if (e->expr_type == EXPR_ARRAY) + { + /* Traverse the constructor looking for variables that are flavor + parameter. Parameters must be expanded since they are fully used at + compile time. */ + for (con = e->value.constructor; con; con = con->next) + { + if (con->expr->expr_type == EXPR_VARIABLE + && con->expr->symtree + && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER + || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) + return true; + if (con->expr->expr_type == EXPR_ARRAY + && gfc_is_expandable_expr (con->expr)) + return true; + } + } + + return false; +} + /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ @@ -5582,14 +5608,20 @@ gfc_resolve_expr (gfc_expr *e) if (t == SUCCESS) { expression_rank (e); - gfc_expand_constructor (e); + if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) + gfc_expand_constructor (e); } /* This provides the opportunity for the length of constructors with character valued function elements to propagate the string length to the expression. */ if (t == SUCCESS && e->ts.type == BT_CHARACTER) - t = gfc_resolve_character_array_constructor (e); + { + /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER + here rather then add a duplicate test for it above. */ + gfc_expand_constructor (e); + t = gfc_resolve_character_array_constructor (e); + } break; -- cgit v1.2.1 From ea3155041c21f1a7aad4e61e4a4705e2d53e264e Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Fri, 15 Jan 2010 01:47:43 +0000 Subject: 2010-01-14 Jerry DeLisle PR fortran/42684 * interface.c (check_interface1): Pass symbol name rather than NULL to gfc_compare_interfaces. (gfc_compare_interfaces): Add assert to trap MULL. * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather than NULL to gfc_compare_interfaces. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155930 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7321c0dd767..9212521b2f3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9712,7 +9712,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } /* Compare the interfaces. */ - if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0)) + if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0)) { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); -- cgit v1.2.1 From b4d11551549cf7c5dab1c580142872a782ebd8ac Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 17 Jan 2010 13:33:11 +0000 Subject: gcc/fortran/ 2010-01-17 Janus Weil PR fortran/42677 * gfortran.h (symbol_attribute): Remove 'ambiguous_interfaces'. * interface.c (check_interface1): Move a warning message here from resolve_fl_procedure. (check_sym_interfaces): Removed 'attr.ambiguous_interfaces'. * module.c (read_module): Remove call to gfc_check_interfaces, since this comes too early here. * resolve.c (resolve_fl_procedure): Move warning message to check_interface1. gcc/testsuite/ 2010-01-17 Janus Weil PR fortran/42677 * gfortran.dg/interface_assignment_5.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155979 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ---- 1 file changed, 4 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9212521b2f3..6bc5fde020b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9077,10 +9077,6 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_formal_arglist *arg; - if (sym->attr.ambiguous_interfaces && !sym->attr.referenced) - gfc_warning ("Although not referenced, '%s' at %L has ambiguous " - "interfaces", sym->name, &sym->declared_at); - if (sym->attr.function && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; -- cgit v1.2.1 From 1b4ad9dac6939b8e1e110e51f70625f48f30023a Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 19 Jan 2010 13:45:07 +0000 Subject: gcc/fortran/ 2010-01-19 Janus Weil PR fortran/42545 * resolve.c (resolve_fl_derived): Set the accessibility of the parent component for extended types. * symbol.c (gfc_find_component): Remove a wrongly-worded error message and take care of parent component accessibility. gcc/testsuite/ 2010-01-19 Janus Weil PR fortran/42545 * gfortran.dg/extends_6.f03: Modified an error message. * gfortran.dg/extends_10.f03: New test. * gfortran.dg/private_type_6.f03: Modified an error message. * gfortran.dg/structure_constructor_8.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156040 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6bc5fde020b..8f32d1a3b66 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10494,6 +10494,12 @@ resolve_fl_derived (gfc_symbol *sym) && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) return FAILURE; + /* If this type is an extension, set the accessibility of the parent + component. */ + if (super_type && c == sym->components + && strcmp (super_type->name, c->name) == 0) + c->attr.access = super_type->attr.access; + /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type -- cgit v1.2.1 From aea8962c06271d18c0807fc3632f5b56d07865d3 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 19 Jan 2010 22:21:35 +0000 Subject: gcc/fortran/ 2010-01-19 Janus Weil PR fortran/42804 * resolve.c (extract_compcall_passed_object): Set locus for passed-object argument. (extract_ppc_passed_object): Set locus and correctly remove PPC reference. gcc/testsuite/ 2010-01-19 Janus Weil PR fortran/42804 * gfortran.dg/proc_ptr_comp_pass_6.f90: New test. * gfortran.dg/typebound_call_12.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156049 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8f32d1a3b66..fe98b7e0a54 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4777,6 +4777,7 @@ extract_compcall_passed_object (gfc_expr* e) po->expr_type = EXPR_VARIABLE; po->symtree = e->symtree; po->ref = gfc_copy_ref (e->ref); + po->where = e->where; } if (gfc_resolve_expr (po) == FAILURE) @@ -4831,11 +4832,12 @@ extract_ppc_passed_object (gfc_expr *e) po->expr_type = EXPR_VARIABLE; po->symtree = e->symtree; po->ref = gfc_copy_ref (e->ref); + po->where = e->where; /* Remove PPC reference. */ ref = &po->ref; while ((*ref)->next) - (*ref) = (*ref)->next; + ref = &(*ref)->next; gfc_free_ref_list (*ref); *ref = NULL; -- cgit v1.2.1 From dba1636be4ca99a50e003734eb53decca6a57b4d Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 31 Jan 2010 21:56:02 +0000 Subject: gcc/fortran/ 2010-01-31 Janus Weil PR fortran/42888 * resolve.c (resolve_allocate_expr): Move default initialization code here from gfc_trans_allocate. * trans.c (gfc_trans_code): Call gfc_trans_class_assign also for EXEC_INIT_ASSIGN. * trans-expr.c (gfc_trans_class_assign): Handle default initialization of CLASS variables via memcpy. * trans-stmt.c (gfc_trans_allocate): Move default initialization code to resolve_allocate_expr. gcc/testsuite/ 2010-01-31 Janus Weil PR fortran/42888 * gfortran.dg/allocate_derived_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156418 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fe98b7e0a54..d0aa6adf9c3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6099,6 +6099,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym; gfc_alloc *a; gfc_component *c; + gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6223,6 +6224,36 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) sym->name, &e->where); return FAILURE; } + + if (!code->expr3) + { + /* Add default initializer for those derived types that need them. */ + if (e->ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&e->ts))) + { + gfc_code *init_st = gfc_get_code (); + init_st->loc = code->loc; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->expr2 = init_e; + init_st->next = code->next; + code->next = init_st; + } + else if (e->ts.type == BT_CLASS + && ((code->ext.alloc.ts.type == BT_UNKNOWN + && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts))) + || (code->ext.alloc.ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + { + gfc_code *init_st = gfc_get_code (); + init_st->loc = code->loc; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->expr2 = init_e; + init_st->next = code->next; + code->next = init_st; + } + } if (pointer || dimension == 0) return SUCCESS; -- cgit v1.2.1 From 7c96794044ca6038994331cf975e1825ca2b4433 Mon Sep 17 00:00:00 2001 From: domob Date: Tue, 9 Feb 2010 10:44:33 +0000 Subject: 2010-02-09 Daniel Kraft PR fortran/39171 * resolve.c (resolve_charlen): Change warning about negative CHARACTER length to be correct and issue only with -Wsurprising. * invoke.texi (Wsurprising): Mention this new warning that is turned on by -Wsurprising. 2010-02-09 Daniel Kraft PR fortran/39171 * gfortran.dg/char_length_2.f90: Change warning expectations accordingly and pass -Wsurprising as necessary. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156620 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d0aa6adf9c3..b525e32b166 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8559,8 +8559,10 @@ resolve_charlen (gfc_charlen *cl) value, the length of character entities declared is zero." */ if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0) { - gfc_warning_now ("CHARACTER variable has zero length at %L", - &cl->length->where); + if (gfc_option.warn_surprising) + gfc_warning_now ("CHARACTER variable at %L has negative length %d," + " the length has been set to zero", + &cl->length->where, i); gfc_replace_expr (cl->length, gfc_int_expr (0)); } -- cgit v1.2.1 From 1fb1e0c8e3a69fac556da924719eefb0ad7836cb Mon Sep 17 00:00:00 2001 From: jakub Date: Thu, 11 Feb 2010 19:47:20 +0000 Subject: PR fortran/43030 * resolve.c (gfc_resolve_dim_arg): Call gfc_clear_ts. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156718 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b525e32b166..bcc8eaeddb5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3958,6 +3958,7 @@ gfc_resolve_dim_arg (gfc_expr *dim) { gfc_typespec ts; + gfc_clear_ts (&ts); ts.type = BT_INTEGER; ts.kind = gfc_index_integer_kind; -- cgit v1.2.1 From 70464669360f2af148f5fba25a763b64b14011b7 Mon Sep 17 00:00:00 2001 From: burnus Date: Sat, 27 Feb 2010 17:25:05 +0000 Subject: 2010-02-27 Tobias Burnus PR fortran/43185 * resolve.c (resolve_fl_variable_derived): Imply SAVE for module variables for Fortran 2008. 2010-02-27 Tobias Burnus PR fortran/43185 * gfortran.dg/default_initialization_1.f90: Add -std=f2003. * gfortran.dg/default_initialization_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157109 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bcc8eaeddb5..4f9eb011537 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8937,13 +8937,12 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) && sym->ns->proc_name->attr.flavor == FL_MODULE && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable - && has_default_initializer (sym->ts.u.derived)) - { - gfc_error("Object '%s' at %L must have the SAVE attribute for " - "default initialization of a component", - sym->name, &sym->declared_at); - return FAILURE; - } + && has_default_initializer (sym->ts.u.derived) + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for " + "module variable '%s' at %L, needed due to " + "the default initialization", sym->name, + &sym->declared_at) == FAILURE) + return FAILURE; if (sym->ts.type == BT_CLASS) { -- cgit v1.2.1 From 9b407bc9896d8ca8ce1b3be8a548bee00349ceb9 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 1 Mar 2010 09:23:35 +0000 Subject: 2010-03-01 Tobias Burnus PR fortran/43199 * resolve.c (find_array_spec): Handle REF_COMPONENT with CLASS components. 2010-03-01 Tobias Burnus PR fortran/43199 * gfortran.dg/module_read_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157133 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4f9eb011537..8de0de616bf 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4007,6 +4007,9 @@ find_array_spec (gfc_expr *e) if (derived == NULL) derived = e->symtree->n.sym->ts.u.derived; + if (derived->attr.is_class) + derived = derived->components->ts.u.derived; + c = derived->components; for (; c; c = c->next) -- cgit v1.2.1 From c4cec8b15b3218836e97207e1f5edf0a5853df58 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 3 Mar 2010 15:12:40 +0000 Subject: 2010-03-03 Janus Weil PR fortran/43169 * resolve.c (resolve_code): Correctly set gfc_current_ns for EXEC_SELECT_TYPE. (gfc_impure_variable): Make it work with sub-namespaces (BLOCK etc). (gfc_pure): Ditto. 2010-03-03 Janus Weil PR fortran/43169 * gfortran.dg/impure_assignment_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157196 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8de0de616bf..10d880762c6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8012,6 +8012,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_DO: gfc_resolve_omp_do_blocks (code, ns); break; + case EXEC_SELECT_TYPE: + gfc_current_ns = code->ext.ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = ns; + break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; @@ -11670,12 +11675,19 @@ int gfc_impure_variable (gfc_symbol *sym) { gfc_symbol *proc; + gfc_namespace *ns; if (sym->attr.use_assoc || sym->attr.in_common) return 1; - if (sym->ns != gfc_current_ns) - return !sym->attr.function; + /* Check if the symbol's ns is inside the pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + if (ns == sym->ns) + break; + if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) + return 1; + } proc = sym->ns->proc_name; if (sym->attr.dummy && gfc_pure (proc) @@ -11691,18 +11703,30 @@ gfc_impure_variable (gfc_symbol *sym) } -/* Test whether a symbol is pure or not. For a NULL pointer, checks the - symbol of the current procedure. */ +/* Test whether a symbol is pure or not. For a NULL pointer, checks if the + current namespace is inside a pure procedure. */ int gfc_pure (gfc_symbol *sym) { symbol_attribute attr; + gfc_namespace *ns; if (sym == NULL) - sym = gfc_current_ns->proc_name; - if (sym == NULL) - return 0; + { + /* Check if the current namespace or one of its parents + belongs to a pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return 0; + attr = sym->attr; + if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental)) + return 1; + } + return 0; + } attr = sym->attr; -- cgit v1.2.1 From b652cb7eec744128892ab74473e52820b4d40dac Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 8 Mar 2010 09:35:04 +0000 Subject: 2010-03-08 Janus Weil PR fortran/43256 * resolve.c (resolve_compcall): Don't set 'value.function.name' here for TBPs, otherwise they will not be resolved properly. (resolve_function): Use 'value.function.esym' instead of 'value.function.name' to check if we're dealing with a TBP. (check_class_members): Set correct type of passed object for all TBPs, not only generic ones, except if the type is abstract. 2010-03-08 Janus Weil PR fortran/43256 * gfortran.dg/typebound_call_13.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157272 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 10d880762c6..16661fdfb40 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2556,8 +2556,8 @@ resolve_function (gfc_expr *expr) } /* If this ia a deferred TBP with an abstract interface (which may - of course be referenced), expr->value.function.name will be set. */ - if (sym && sym->attr.abstract && !expr->value.function.name) + of course be referenced), expr->value.function.esym will be set. */ + if (sym && sym->attr.abstract && !expr->value.function.esym) { gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", sym->name, &expr->where); @@ -5124,7 +5124,7 @@ resolve_compcall (gfc_expr* e, bool fcn) return FAILURE; e->value.function.actual = newactual; - e->value.function.name = e->value.compcall.name; + e->value.function.name = NULL; e->value.function.esym = target->n.sym; e->value.function.class_esym = NULL; e->value.function.isym = NULL; @@ -5178,18 +5178,17 @@ check_class_members (gfc_symbol *derived) return; } - if (tbp->n.tb->is_generic) + /* If we have to match a passed class member, force the actual + expression to have the correct type. */ + if (!tbp->n.tb->nopass) { - /* If we have to match a passed class member, force the actual - expression to have the correct type. */ - if (!tbp->n.tb->nopass) - { - if (e->value.compcall.base_object == NULL) - e->value.compcall.base_object = - extract_compcall_passed_object (e); + if (e->value.compcall.base_object == NULL) + e->value.compcall.base_object = extract_compcall_passed_object (e); - e->value.compcall.base_object->ts.type = BT_DERIVED; - e->value.compcall.base_object->ts.u.derived = derived; + if (!derived->attr.abstract) + { + e->value.compcall.base_object->ts.type = BT_DERIVED; + e->value.compcall.base_object->ts.u.derived = derived; } } -- cgit v1.2.1 From ae925cc0be9d082b4556afb102e0c255a1f8ae1d Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 12 Mar 2010 22:00:52 +0000 Subject: 2010-03-12 Paul Thomas PR fortran/43291 PR fortran/43326 * resolve.c (resolve_compcall): Add new boolean dummy argument 'class_members'. Only resolve expression at end if false. Remove redundant, static variable 'class_object'. (check_class_members): Add extra argument to call of resolve_compcall. (resolve_typebound_function): Renamed resolve_class_compcall. Do all the detection of class references here. Correct calls to resolve_compcall for extra argument. (resolve_typebound_subroutine): resolve_class_typebound_call renamed. Otherwise same as resolve_typebound_function. (gfc_resolve_expr): Call resolve_typebound_function. (resolve_code): Call resolve_typebound_subroutine. 2010-03-12 Paul Thomas PR fortran/43291 PR fortran/43326 * gfortran.dg/dynamic_dispatch_7.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157411 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 56 +++++++++++++++++++++++++++------------------------ 1 file changed, 30 insertions(+), 26 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 16661fdfb40..9a95d3405a0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5082,7 +5082,7 @@ resolve_typebound_call (gfc_code* c) resolving subroutine class methods, since we do not have to add a gfc_code each time. */ static gfc_try -resolve_compcall (gfc_expr* e, bool fcn) +resolve_compcall (gfc_expr* e, bool fcn, bool class_members) { gfc_actual_arglist* newactual; gfc_symtree* target; @@ -5132,10 +5132,10 @@ resolve_compcall (gfc_expr* e, bool fcn) e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; - /* Resolution is not necessary if this is a class subroutine; this - function only has to identify the specific proc. Resolution of - the call will be done next in resolve_typebound_call. */ - return fcn ? gfc_resolve_expr (e) : SUCCESS; + /* Resolution is not necessary when constructing component calls + for class members, since this must only be done for the + declared type, which is done afterwards. */ + return !class_members ? gfc_resolve_expr (e) : SUCCESS; } @@ -5147,7 +5147,6 @@ static gfc_expr *list_e; static void check_class_members (gfc_symbol *); static gfc_try class_try; static bool fcn_flag; -static gfc_symbol *class_object; static void @@ -5202,7 +5201,7 @@ check_class_members (gfc_symbol *derived) /* Do the renaming, PASSing, generic => specific and other good things for each class member. */ - class_try = (resolve_compcall (e, fcn_flag) == SUCCESS) + class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS) ? class_try : FAILURE; /* Now transfer the found symbol to the esym list. */ @@ -5337,9 +5336,13 @@ resolve_arg_exprs (gfc_actual_arglist *arg) } -/* Resolve a CLASS typebound function, or 'method'. */ +/* Resolve a typebound function, or 'method'. First separate all + the non-CLASS references by calling resolve_compcall directly. + Then treat the CLASS references by resolving for each of the class + members in turn. */ + static gfc_try -resolve_class_compcall (gfc_expr* e) +resolve_typebound_function (gfc_expr* e) { gfc_symbol *derived, *declared; gfc_ref *new_ref; @@ -5347,16 +5350,18 @@ resolve_class_compcall (gfc_expr* e) gfc_symtree *st; st = e->symtree; - class_object = st->n.sym; + if (st == NULL) + return resolve_compcall (e, true, false); /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); /* Weed out cases of the ultimate component being a derived type. */ - if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); - return resolve_compcall (e, true); + return resolve_compcall (e, true, false); } /* Resolve the argument expressions, */ @@ -5371,7 +5376,7 @@ resolve_class_compcall (gfc_expr* e) list_e = gfc_copy_expr (e); check_class_members (derived); - class_try = (resolve_compcall (e, true) == SUCCESS) + class_try = (resolve_compcall (e, true, false) == SUCCESS) ? class_try : FAILURE; /* Transfer the class list to the original expression. Note that @@ -5392,9 +5397,13 @@ resolve_class_compcall (gfc_expr* e) return class_try; } -/* Resolve a CLASS typebound subroutine, or 'method'. */ +/* Resolve a typebound subroutine, or 'method'. First separate all + the non-CLASS references by calling resolve_typebound_call directly. + Then treat the CLASS references by resolving for each of the class + members in turn. */ + static gfc_try -resolve_class_typebound_call (gfc_code *code) +resolve_typebound_subroutine (gfc_code *code) { gfc_symbol *derived, *declared; gfc_ref *new_ref; @@ -5402,13 +5411,15 @@ resolve_class_typebound_call (gfc_code *code) gfc_symtree *st; st = code->expr1->symtree; - class_object = st->n.sym; + if (st == NULL) + return resolve_typebound_call (code); /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ - if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); return resolve_typebound_call (code); @@ -5584,10 +5595,7 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_COMPCALL: - if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - t = resolve_class_compcall (e); - else - t = resolve_compcall (e, true); + t = resolve_typebound_function (e); break; case EXPR_SUBSTRING: @@ -8150,11 +8158,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_COMPCALL: compcall: - if (code->expr1->symtree - && code->expr1->symtree->n.sym->ts.type == BT_CLASS) - resolve_class_typebound_call (code); - else - resolve_typebound_call (code); + resolve_typebound_subroutine (code); break; case EXEC_CALL_PPC: -- cgit v1.2.1 From 895e6dfa853f665e87eb759d7230abbf28676b46 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 14 Mar 2010 13:18:28 +0000 Subject: 2010-03-14 Tobias Burnus PR fortran/43362 * resolve.c (resolve_structure_cons): Add missing PURE * constraint. (resolve_ordinary_assign): Add check to avoid segfault. 2010-03-14 Tobias Burnus PR fortran/43362 * gfortran.dg/impure_constructor_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157447 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9a95d3405a0..774dfe4f2ea 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -921,6 +921,16 @@ resolve_structure_cons (gfc_expr *expr) "for pointer component '%s' should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); } + + /* F2003, C1272 (3). */ + if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE + && gfc_impure_variable (cons->expr->symtree->n.sym)) + { + t = FAILURE; + gfc_error ("Invalid expression in the derived type constructor for pointer " + "component '%s' at %L in PURE procedure", comp->name, + &cons->expr->where); + } } return t; @@ -7947,6 +7957,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) if (lhs->ts.type == BT_DERIVED && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp + && rhs->expr_type == EXPR_VARIABLE && gfc_impure_variable (rhs->symtree->n.sym)) { gfc_error ("The impure variable at %L is assigned to " -- cgit v1.2.1 From 452695a8da676319b005b0fdfafc623139ea2f83 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 17 Mar 2010 09:53:40 +0000 Subject: 2010-03-17 Tobias Burnus PR fortran/43331 * trans-array.c (gfc_conv_array_index_offset,gfc_conv_array_ref, gfc_conv_ss_startstride): Remove no-longer-needed cp_was_assumed check. * decl.c (gfc_match_derived_decl): Don't mark assumed-size Cray pointees as having explizit size. * expr.c (gfc_check_assign): Remove now unreachable Cray pointee check. * trans-types.c (gfc_is_nodesc_array): Add cp_was_assumed to * assert. (gfc_sym_type): Don't mark Cray pointees as restricted pointers. * resolve.c (resolve_symbol): Handle cp_was_assumed. * trans-decl.c (gfc_trans_deferred_vars): Ditto. (gfc_finish_var_decl): Don't mark Cray pointees as restricted pointers. 2010-03-17 Tobias Burnus PR fortran/43331 * gfortran.dg/cray_pointers_1.f90: Update dg-error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157512 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 774dfe4f2ea..de316da840d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11010,7 +11010,7 @@ resolve_symbol (gfc_symbol *sym) arguments. */ if (sym->as != NULL - && (sym->as->type == AS_ASSUMED_SIZE + && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed) || sym->as->type == AS_ASSUMED_SHAPE) && sym->attr.dummy == 0) { -- cgit v1.2.1 From 8fcd6158bb904c5f6b404d1297aeb85275a6b9ae Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 18 Mar 2010 21:23:35 +0000 Subject: 2010-03-18 Paul Thomas PR fortran/43039 * trans-expr.c (conv_parent_component_references): Ensure that 'dt' has a backend_decl. PR fortran/43043 * trans-expr.c (gfc_conv_structure): Ensure that the derived type has a backend_decl. PR fortran/43044 * resolve.c (resolve_global_procedure): Check that the 'cl' structure is not NULL. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157552 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index de316da840d..24ec7a8a1de 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1851,12 +1851,13 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Non-assumed length character functions. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) + && gsym->ns->proc_name->ts.u.cl != NULL + && gsym->ns->proc_name->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) { gfc_error ("Nonconstant character-length function '%s' at %L " "must have an explicit interface", sym->name, -- cgit v1.2.1 From c6cd3066bcb72a59fecce6bfa99cb4e169a4a751 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 16:26:02 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/39997 * intrinsic.c (add_functions): Add num_images. * decl.c (gfc_match_end): Handle END CRITICAL. * intrinsic.h (gfc_simplify_num_images): Add prototype. * dump-parse-tree.c (show_code_node): Dump CRITICAL, ERROR STOP, and SYNC. * gfortran.h (gfc_statement): Add enum items for those. (gfc_exec_op) Ditto. (gfc_isym_id): Add num_images. * trans-stmt.c (gfc_trans_stop): Handle ERROR STOP. (gfc_trans_sync,gfc_trans_critical): New functions. * trans-stmt.h (gfc_trans_stop,gfc_trans_sync, gfc_trans_critical): Add/update prototypes. * trans.c (gfc_trans_code): Handle CRITICAL, ERROR STOP, and SYNC statements. * trans.h (gfor_fndecl_error_stop_string) Add variable. * resolve.c (resolve_sync): Add function. (gfc_resolve_blocks): Handle CRITICAL. (resolve_code): Handle CRITICAL, ERROR STOP, (resolve_branch): Add CRITICAL constraint check. and SYNC statements. * st.c (gfc_free_statement): Add new statements. * trans-decl.c (gfor_fndecl_error_stop_string): Global variable. (gfc_build_builtin_function_decls): Initialize it. * match.c (gfc_match_if): Handle ERROR STOP and SYNC. (gfc_match_critical, gfc_match_error_stop, sync_statement, gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory): New functions. (match_exit_cycle): Handle CRITICAL constraint. (gfc_match_stopcode): Handle ERROR STOP. * match.h (gfc_match_critical, gfc_match_error_stop, gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory): Add prototype. * parse.c (decode_statement, gfc_ascii_statement, parse_executable): Handle new statements. (parse_critical_block): New function. * parse.h (gfc_compile_state): Add COMP_CRITICAL. * intrinsic.texi (num_images): Document new function. * simplify.c (gfc_simplify_num_images): Add function. 2010-04-06 Tobias Burnus PR fortran/39997 * gfortran.dg/coarray_1.f90: New test. * gfortran.dg/coarray_2.f90: New test. * gfortran.dg/coarray_3.f90: New test. 2010-04-06 Tobias Burnus PR fortran/39997 * runtime/stop.c (error_stop_string): New function. * gfortran.map (_gfortran_error_stop_string): Add. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158008 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 78 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 75 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 24ec7a8a1de..8ef347d1ac8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7315,6 +7315,48 @@ find_reachable_labels (gfc_code *block) } } + +static void +resolve_sync (gfc_code *code) +{ + /* Check imageset. The * case matches expr1 == NULL. */ + if (code->expr1) + { + if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) + gfc_error ("Imageset argument at %L must be a scalar or rank-1 " + "INTEGER expression", &code->expr1->where); + if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 + && mpz_cmp_si (code->expr1->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and num_images()", + &code->expr1->where); + else if (code->expr1->expr_type == EXPR_ARRAY + && gfc_simplify_expr (code->expr1, 0) == SUCCESS) + { + gfc_constructor *cons; + for (cons = code->expr1->value.constructor; cons; cons = cons->next) + if (cons->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (cons->expr->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and " + "num_images()", &cons->expr->where); + } + } + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); +} + + /* Given a branch to a label, see if the branch is conforming. The code node describes where the branch is located. */ @@ -7355,15 +7397,36 @@ resolve_branch (gfc_st_label *label, gfc_code *code) the bitmap reachable_labels. */ if (bitmap_bit_p (cs_base->reachable_labels, label->value)) - return; + { + /* Check now whether there is a CRITICAL construct; if so, check + whether the label is still visible outside of the CRITICAL block, + which is invalid. */ + for (stack = cs_base; stack; stack = stack->prev) + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + " at %L", &code->loc, &label->where); + + return; + } /* Step four: If we haven't found the label in the bitmap, it may still be the label of the END of the enclosing block, in which case we find it by going up the code_stack. */ for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->next && stack->current->next->here == label) - break; + { + if (stack->current->next && stack->current->next->here == label) + break; + if (stack->current->op == EXEC_CRITICAL) + { + /* Note: A label at END CRITICAL does not leave the CRITICAL + construct as END CRITICAL is still part of it. */ + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + " at %L", &code->loc, &label->where); + return; + } + } if (stack) { @@ -7788,6 +7851,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: + case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: case EXEC_IOLENGTH: @@ -8068,10 +8132,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_CYCLE: case EXEC_PAUSE: case EXEC_STOP: + case EXEC_ERROR_STOP: case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: case EXEC_ASSIGN_CALL: + case EXEC_CRITICAL: + break; + + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + resolve_sync (code); break; case EXEC_ENTRY: -- cgit v1.2.1 From aff518b0c6c0be70a7a986a3abe418ddc323eaf8 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 18:16:13 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/18918 * array.c (gfc_free_array_spec,gfc_resolve_array_spec, match_array_element_spec,gfc_copy_array_spec, gfc_compare_array_spec): Include corank. (match_array_element_spec,gfc_set_array_spec): Support codimension. * decl.c (build_sym,build_struct,variable_decl, match_attr_spec,attr_decl1,cray_pointer_decl, gfc_match_volatile): Add codimension. (gfc_match_codimension): New function. * dump-parse-tree.c (show_array_spec,show_attr): Support * codimension. * gfortran.h (symbol_attribute,gfc_array_spec): Ditto. (gfc_add_codimension): New function prototype. * match.h (gfc_match_codimension): New function prototype. (gfc_match_array_spec): Update prototype * match.c (gfc_match_common): Update gfc_match_array_spec call. * module.c (MOD_VERSION): Bump. (mio_symbol_attribute): Support coarray attributes. (mio_array_spec): Add corank support. * parse.c (decode_specification_statement,decode_statement, parse_derived): Add coarray support. * resolve.c (resolve_formal_arglist, was_declared, is_non_constant_shape_array, resolve_fl_variable, resolve_fl_derived, resolve_symbol): Add coarray support. * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr, gfc_build_class_symbol): Add coarray support. (gfc_add_codimension): New function. 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_4.f90: New test. * gfortran.dg/coarray_5.f90: New test. * gfortran.dg/coarray_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158012 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 103 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 99 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8ef347d1ac8..55c0d124f51 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -258,6 +258,14 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc)) { + /* F2008, C1289. */ + if (sym->attr.codimension) + { + gfc_error ("Coarray dummy argument '%s' at %L to elemental " + "procedure", sym->name, &sym->declared_at); + continue; + } + if (sym->as != NULL) { gfc_error ("Argument '%s' of elemental procedure at %L must " @@ -955,7 +963,7 @@ was_declared (gfc_symbol *sym) if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous) + || a.asynchronous || a.codimension) return 1; return 0; @@ -8691,13 +8699,12 @@ is_non_constant_shape_array (gfc_symbol *sym) /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that has not been simplified; parameter array references. Do the simplification now. */ - for (i = 0; i < sym->as->rank; i++) + for (i = 0; i < sym->as->rank + sym->as->corank; i++) { e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) not_constant = true; - e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) @@ -9147,7 +9154,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.intrinsic || sym->attr.result) no_init_flag = 1; - else if (sym->attr.dimension && !sym->attr.pointer + else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer && is_non_constant_shape_array (sym)) { no_init_flag = automatic_flag = 1; @@ -10431,6 +10438,15 @@ resolve_fl_derived (gfc_symbol *sym) super_type = gfc_get_derived_super_type (sym); + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type '%s' at %L has a coarray component, " + "parent type '%s' shall also have one", sym->name, + &sym->declared_at, super_type->name); + return FAILURE; + } + /* Ensure the extended type gets resolved before we do. */ if (super_type && resolve_fl_derived (super_type) == FAILURE) return FAILURE; @@ -10445,6 +10461,34 @@ resolve_fl_derived (gfc_symbol *sym) for (c = sym->components; c != NULL; c = c->next) { + /* F2008, C442. */ + if (c->attr.codimension + && (!c->attr.allocatable || c->as->type != AS_DEFERRED)) + { + gfc_error ("Coarray component '%s' at %L must be allocatable with " + "deferred shape", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) + { + gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C444. */ + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension)) + { + gfc_error ("Component '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure) @@ -11275,6 +11319,57 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->attr.codimension && sym->attr.allocatable + && sym->as->type != AS_DEFERRED) + gfc_error ("Allocatable coarray variable '%s' at %L must have " + "deferred shape", sym->name, &sym->declared_at); + + /* F2008, C526. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && sym->attr.result) + gfc_error ("Function result '%s' at %L shall not be a coarray or have " + "a coarray component", sym->name, &sym->declared_at); + + /* F2008, C524. */ + if (sym->attr.codimension && sym->ts.type == BT_DERIVED + && sym->ts.u.derived->ts.is_iso_c) + gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", sym->name, &sym->declared_at); + + /* F2008, C525. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp + && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension + || sym->attr.allocatable)) + gfc_error ("Variable '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + sym->name, &sym->declared_at); + + /* F2008, C526. The function-result case was handled above. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program + || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) + gfc_error ("Variable '%s' at %L is a coarray or has a coarray " + "component and is not ALLOCATABLE, SAVE nor a " + "dummy argument", sym->name, &sym->declared_at); + + /* F2008, C541. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->attr.codimension && sym->attr.allocatable)) + && sym->attr.dummy && sym->attr.intent == INTENT_OUT) + gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an " + "allocatable coarray or have coarray components", + sym->name, &sym->declared_at); + + if (sym->attr.codimension && sym->attr.dummy + && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) + gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) " + "procedure '%s'", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + switch (sym->attr.flavor) { case FL_VARIABLE: -- cgit v1.2.1 From 2d640d61aabac1395dd2f903d406cf037df4cf7e Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 18:23:56 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.h (gfc_array_spec): Add cotype. * array.c (gfc_match_array_spec,gfc_set_array_spec): Use it and defer error diagnostic. * resolve.c (resolve_fl_derived): Add missing check. (resolve_symbol): Add cotype/type check. * parse.c (parse_derived): Fix setting of coarray_comp. 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_4.f90: Fix test. * gfortran.dg/coarray_6.f90: Add more tests. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158014 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 55c0d124f51..3ec454e7b73 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10481,7 +10481,8 @@ resolve_fl_derived (gfc_symbol *sym) /* F2008, C444. */ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp - && (c->attr.codimension || c->attr.pointer || c->attr.dimension)) + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) { gfc_error ("Component '%s' at %L with coarray component " "shall be a nonpointer, nonallocatable scalar", @@ -11319,11 +11320,6 @@ resolve_symbol (gfc_symbol *sym) } } - if (sym->attr.codimension && sym->attr.allocatable - && sym->as->type != AS_DEFERRED) - gfc_error ("Allocatable coarray variable '%s' at %L must have " - "deferred shape", sym->name, &sym->declared_at); - /* F2008, C526. */ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || sym->attr.codimension) @@ -11355,6 +11351,16 @@ resolve_symbol (gfc_symbol *sym) gfc_error ("Variable '%s' at %L is a coarray or has a coarray " "component and is not ALLOCATABLE, SAVE nor a " "dummy argument", sym->name, &sym->declared_at); + /* F2008, C528. */ + else if (sym->attr.codimension && !sym->attr.allocatable + && sym->as->cotype == AS_DEFERRED) + gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " + "deferred shape", sym->name, &sym->declared_at); + else if (sym->attr.codimension && sym->attr.allocatable + && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED)) + gfc_error ("Allocatable coarray variable '%s' at %L must have " + "deferred shape", sym->name, &sym->declared_at); + /* F2008, C541. */ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) -- cgit v1.2.1 From e97ac7c06c53487872b7d9d11148725317ef5588 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 9 Apr 2010 05:54:29 +0000 Subject: 2010-04-09 Tobias Burnus PR fortran/18918 * decl.c (variable_decl, match_attr_spec): Fix setting the array spec. * array.c (match_subscript,gfc_match_array_ref): Add coarray * support. * data.c (gfc_assign_data_value): Ditto. * expr.c (gfc_check_pointer_assign): Add check for coarray * constraint. (gfc_traverse_expr): Traverse also through codimension expressions. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): New functions. * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for * coarrays. (gfc_array_ref): Add codimen. (gfc_array_ref): Add in_allocate. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): Add prototypes. * interface.c (compare_parameter, compare_actual_formal, check_intents): Add coarray constraints. * match.c (gfc_match_iterator): Add coarray constraint. * match.h (gfc_match_array_ref): Update interface. * primary.c (gfc_match_varspec): Handle codimensions. * resolve.c (coarray_alloc, inquiry_argument): New static * variables. (check_class_members): Return gfc_try instead for error recovery. (resolve_typebound_function,resolve_typebound_subroutine, check_members): Handle return value of check_class_members. (resolve_structure_cons, resolve_actual_arglist, resolve_function, check_dimension, compare_spec_to_ref, resolve_array_ref, resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays, resolve_allocate_expr, resolve_ordinary_assign): Add coarray support. * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr): Skip over coarray refs. (gfc_array_allocate) Add support for references containing coindexes. * trans-expr.c (gfc_add_interface_mapping): Copy coarray * attribute. (gfc_map_intrinsic_function): Ignore codimensions. 2010-04-09 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_7.f90: New test. * gfortran.dg/coarray_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158149 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 321 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 278 insertions(+), 43 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3ec454e7b73..5e9b25c8a16 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -77,6 +77,9 @@ static int current_entry_id; /* We use bitmaps to determine if a branch target is valid. */ static bitmap_obstack labels_obstack; +/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ +static bool inquiry_argument = false; + int gfc_is_formal_arg (void) { @@ -932,12 +935,13 @@ resolve_structure_cons (gfc_expr *expr) /* F2003, C1272 (3). */ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE - && gfc_impure_variable (cons->expr->symtree->n.sym)) + && (gfc_impure_variable (cons->expr->symtree->n.sym) + || gfc_is_coindexed (cons->expr))) { t = FAILURE; - gfc_error ("Invalid expression in the derived type constructor for pointer " - "component '%s' at %L in PURE procedure", comp->name, - &cons->expr->where); + gfc_error ("Invalid expression in the derived type constructor for " + "pointer component '%s' at %L in PURE procedure", + comp->name, &cons->expr->where); } } @@ -1319,7 +1323,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; gfc_component *comp; - + for (; arg; arg = arg->next) { e = arg->expr; @@ -1549,6 +1553,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } } } + + /* Fortran 2008, C1237. */ + if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " + "component", &e->where); + return FAILURE; + } } return SUCCESS; @@ -2590,11 +2603,19 @@ resolve_function (gfc_expr *expr) if (expr->symtree && expr->symtree->n.sym) p = expr->symtree->n.sym->attr.proc; + if (expr->value.function.isym && expr->value.function.isym->inquiry) + inquiry_argument = true; no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL; + if (resolve_actual_arglist (expr->value.function.actual, p, no_formal_args) == FAILURE) + { + inquiry_argument = false; return FAILURE; + } + inquiry_argument = false; + /* Need to setup the call to the correct c_associated, depending on the number of cptrs to user gives to compare. */ if (sym && sym->attr.is_iso_c == 1) @@ -3755,6 +3776,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { mpz_t last_value; + if (ar->dimen_type[i] == DIMEN_STAR) + { + gcc_assert (ar->stride[i] == NULL); + /* This implies [*] as [*:] and [*:3] are not possible. */ + if (ar->start[i] == NULL) + { + gcc_assert (ar->end[i] == NULL); + return SUCCESS; + } + } + /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ @@ -3763,21 +3795,36 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) case DIMEN_VECTOR: break; + case DIMEN_STAR: case DIMEN_ELEMENT: if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->lower[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->upper[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } @@ -3897,10 +3944,32 @@ compare_spec_to_ref (gfc_array_ref *ar) return FAILURE; } + /* ar->codimen == 0 is a local array. */ + if (as->corank != ar->codimen && ar->codimen != 0) + { + gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->codimen, as->corank); + return FAILURE; + } + for (i = 0; i < as->rank; i++) if (check_dimension (i, ar, as) == FAILURE) return FAILURE; + /* Local access has no coarray spec. */ + if (ar->codimen != 0) + for (i = as->rank; i < as->rank + as->corank; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + { + gfc_error ("Coindex of codimension %d must be a scalar at %L", + i + 1 - as->rank, &ar->where); + return FAILURE; + } + if (check_dimension (i, ar, as) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -4069,7 +4138,7 @@ resolve_array_ref (gfc_array_ref *ar) int i, check_scalar; gfc_expr *e; - for (i = 0; i < ar->dimen; i++) + for (i = 0; i < ar->dimen + ar->codimen; i++) { check_scalar = ar->dimen_type[i] == DIMEN_RANGE; @@ -4103,6 +4172,9 @@ resolve_array_ref (gfc_array_ref *ar) } } + if (ar->type == AR_FULL && ar->as->rank == 0) + ar->type = AR_ELEMENT; + /* If the reference type is unknown, figure out what kind it is. */ if (ar->type == AR_UNKNOWN) @@ -4307,6 +4379,13 @@ resolve_ref (gfc_expr *expr) switch (ref->u.ar.type) { case AR_FULL: + /* Coarray scalar. */ + if (ref->u.ar.as->rank == 0) + { + current_part_dimension = 0; + break; + } + /* Fall through. */ case AR_SECTION: current_part_dimension = 1; break; @@ -4576,6 +4655,47 @@ resolve_procedure: if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) t = FAILURE; + /* F2008, C617 and C1229. */ + if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) + && gfc_is_coindexed (e)) + { + gfc_ref *ref, *ref2 = NULL; + + if (e->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic subobject of coindexed object at %L", + &e->where); + t = FAILURE; + } + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + ref2 = ref; + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + } + + for ( ; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + /* Expression itself is coindexed object. */ + if (ref == NULL) + { + gfc_component *c; + c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; + for ( ; c; c = c->next) + if (c->attr.allocatable && c->ts.type == BT_CLASS) + { + gfc_error ("Coindexed object with polymorphic allocatable " + "subcomponent at %L", &e->where); + t = FAILURE; + break; + } + } + } + return t; } @@ -5163,7 +5283,7 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) of f03 OOP. As soon as vtables are in place and contain pointers to methods, this will no longer be necessary. */ static gfc_expr *list_e; -static void check_class_members (gfc_symbol *); +static gfc_try check_class_members (gfc_symbol *); static gfc_try class_try; static bool fcn_flag; @@ -5172,11 +5292,11 @@ static void check_members (gfc_symbol *derived) { if (derived->attr.flavor == FL_DERIVED) - check_class_members (derived); + (void) check_class_members (derived); } -static void +static gfc_try check_class_members (gfc_symbol *derived) { gfc_expr *e; @@ -5193,7 +5313,7 @@ check_class_members (gfc_symbol *derived) { gfc_error ("no typebound available procedure named '%s' at %L", e->value.compcall.name, &e->where); - return; + return FAILURE; } /* If we have to match a passed class member, force the actual @@ -5203,6 +5323,9 @@ check_class_members (gfc_symbol *derived) if (e->value.compcall.base_object == NULL) e->value.compcall.base_object = extract_compcall_passed_object (e); + if (e->value.compcall.base_object == NULL) + return FAILURE; + if (!derived->attr.abstract) { e->value.compcall.base_object->ts.type = BT_DERIVED; @@ -5240,6 +5363,8 @@ check_class_members (gfc_symbol *derived) /* Burrow down into grandchildren types. */ if (derived->f2k_derived) gfc_traverse_ns (derived->f2k_derived, check_members); + + return SUCCESS; } @@ -5393,7 +5518,9 @@ resolve_typebound_function (gfc_expr* e) class_try = SUCCESS; fcn_flag = true; list_e = gfc_copy_expr (e); - check_class_members (derived); + + if (check_class_members (derived) == FAILURE) + return FAILURE; class_try = (resolve_compcall (e, true, false) == SUCCESS) ? class_try : FAILURE; @@ -5453,7 +5580,9 @@ resolve_typebound_subroutine (gfc_code *code) class_try = SUCCESS; fcn_flag = false; list_e = gfc_copy_expr (code->expr1); - check_class_members (derived); + + if (check_class_members (derived) == FAILURE) + return FAILURE; class_try = (resolve_typebound_call (code) == SUCCESS) ? class_try : FAILURE; @@ -5585,10 +5714,16 @@ gfc_try gfc_resolve_expr (gfc_expr *e) { gfc_try t; + bool inquiry_save; if (e == NULL) return SUCCESS; + /* inquiry_argument only applies to variables. */ + inquiry_save = inquiry_argument; + if (e->expr_type != EXPR_VARIABLE) + inquiry_argument = false; + switch (e->expr_type) { case EXPR_OP: @@ -5676,6 +5811,8 @@ gfc_resolve_expr (gfc_expr *e) if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) fixup_charlen (e); + inquiry_argument = inquiry_save; + return t; } @@ -6123,6 +6260,7 @@ static gfc_try resolve_allocate_expr (gfc_expr *e, gfc_code *code) { int i, pointer, allocatable, dimension, check_intent_in, is_abstract; + int codimension; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; @@ -6134,8 +6272,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; + /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR + checking of coarrays. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + + if (ref && ref->type == REF_ARRAY) + ref->u.ar.in_allocate = true; + if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto failure; /* Make sure the expression is allocatable or a pointer. If it is pointer, the next-to-last reference must be a pointer. */ @@ -6153,6 +6300,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) attr = gfc_expr_attr (e); pointer = attr.pointer; dimension = attr.dimension; + codimension = attr.codimension; } else { @@ -6161,6 +6309,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = sym->ts.u.derived->components->attr.allocatable; pointer = sym->ts.u.derived->components->attr.pointer; dimension = sym->ts.u.derived->components->attr.dimension; + codimension = sym->ts.u.derived->components->attr.codimension; is_abstract = sym->ts.u.derived->components->attr.abstract; } else @@ -6168,6 +6317,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = sym->attr.allocatable; pointer = sym->attr.pointer; dimension = sym->attr.dimension; + codimension = sym->attr.codimension; } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) @@ -6183,12 +6333,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) break; case REF_COMPONENT: + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", + &e->where); + goto failure; + } + c = ref->u.c.component; if (c->ts.type == BT_CLASS) { allocatable = c->ts.u.derived->components->attr.allocatable; pointer = c->ts.u.derived->components->attr.pointer; dimension = c->ts.u.derived->components->attr.dimension; + codimension = c->ts.u.derived->components->attr.codimension; is_abstract = c->ts.u.derived->components->attr.abstract; } else @@ -6196,6 +6355,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; + codimension = c->attr.codimension; is_abstract = c->attr.abstract; } break; @@ -6212,7 +6372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); - return FAILURE; + goto failure; } /* Some checks for the SOURCE tag. */ @@ -6223,13 +6383,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && conformable_arrays (code->expr3, e) == FAILURE) - return FAILURE; + goto failure; /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind) @@ -6237,7 +6397,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_error ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } } else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) @@ -6245,14 +6405,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " "type-spec or SOURCE=", sym->name, &e->where); - return FAILURE; + goto failure; } if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", sym->name, &e->where); - return FAILURE; + goto failure; } if (!code->expr3) @@ -6285,16 +6445,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } } - if (pointer || dimension == 0) - return SUCCESS; + if (pointer || (dimension == 0 && codimension == 0)) + goto success; /* Make sure the next-to-last reference node is an array specification. */ - if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL) + if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL + || (dimension && ref2->u.ar.dimen == 0)) { gfc_error ("Array specification required in ALLOCATE statement " "at %L", &e->where); - return FAILURE; + goto failure; } /* Make sure that the array section reference makes sense in the @@ -6302,6 +6463,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ar = &ref2->u.ar; + if (codimension && ar->codimen == 0) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } + for (i = 0; i < ar->dimen; i++) { if (ref2->u.ar.type == AR_ELEMENT) @@ -6322,13 +6490,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: + case DIMEN_STAR: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); - return FAILURE; + goto failure; } check_symbols: - for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; @@ -6345,12 +6513,46 @@ check_symbols: gfc_error ("'%s' must not appear in the array specification at " "%L in the same ALLOCATE statement where it is " "itself allocated", sym->name, &ar->where); - return FAILURE; + goto failure; } } } + for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_ELEMENT + || ar->dimen_type[i] == DIMEN_RANGE) + { + if (i == (ar->dimen + ar->codimen - 1)) + { + gfc_error ("Expected '*' in coindex specification in ALLOCATE " + "statement at %L", &e->where); + goto failure; + } + break; + } + + if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) + && ar->stride[i] == NULL) + break; + + gfc_error ("Bad coarray specification in ALLOCATE statement at %L", + &e->where); + goto failure; + } + + if (codimension) + { + gfc_error ("Sorry, allocatable coarrays are no yet supported coarray " + "at %L", &e->where); + goto failure; + } + +success: return SUCCESS; + +failure: + return FAILURE; } static void @@ -8031,17 +8233,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp && rhs->expr_type == EXPR_VARIABLE - && gfc_impure_variable (rhs->symtree->n.sym)) + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + { + /* F2008, C1283. */ + if (gfc_is_coindexed (rhs)) + gfc_error ("Coindexed expression at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure", + &rhs->where); + else + gfc_error ("The impure variable at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure (12.6)", + &rhs->where); + return rval; + } + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) { - gfc_error ("The impure variable at %L is assigned to " - "a derived type variable with a POINTER " - "component in a PURE procedure (12.6)", - &rhs->where); + gfc_error ("Assignment to coindexed variable at %L in a PURE " + "procedure", &rhs->where); return rval; } } /* F03:7.4.1.2. */ + /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic + and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */ if (lhs->ts.type == BT_CLASS) { gfc_error ("Variable must not be polymorphic in assignment at %L", @@ -8049,6 +8269,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) return false; } + /* F2008, Section 7.2.1.2. */ + if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs)) + { + gfc_error ("Coindexed variable must not be have an allocatable ultimate " + "component in assignment at %L", &lhs->where); + return false; + } + gfc_check_assign (lhs, rhs, 1); return false; } @@ -10462,8 +10690,8 @@ resolve_fl_derived (gfc_symbol *sym) for (c = sym->components; c != NULL; c = c->next) { /* F2008, C442. */ - if (c->attr.codimension - && (!c->attr.allocatable || c->as->type != AS_DEFERRED)) + if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */ + && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { gfc_error ("Coarray component '%s' at %L must be allocatable with " "deferred shape", c->name, &c->loc); @@ -11351,9 +11579,9 @@ resolve_symbol (gfc_symbol *sym) gfc_error ("Variable '%s' at %L is a coarray or has a coarray " "component and is not ALLOCATABLE, SAVE nor a " "dummy argument", sym->name, &sym->declared_at); - /* F2008, C528. */ + /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */ else if (sym->attr.codimension && !sym->attr.allocatable - && sym->as->cotype == AS_DEFERRED) + && sym->as && sym->as->cotype == AS_DEFERRED) gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " "deferred shape", sym->name, &sym->declared_at); else if (sym->attr.codimension && sym->attr.allocatable @@ -11548,6 +11776,13 @@ check_data_variable (gfc_data_variable *var, locus *where) if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) has_pointer = 1; + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", + sym->name, where); + return FAILURE; + } + if (has_pointer && ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) -- cgit v1.2.1 From 126387b5b6b5a55db23d87e27562c91cc235c906 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Tue, 13 Apr 2010 01:59:35 +0000 Subject: 2010-04-12 Jerry DeLisle * array.c (extract_element): Restore function from trunk. (gfc_get_array_element): Restore function from trunk. (gfc_expand_constructor): Restore check against flag_max_array_constructor. * constructor.c (node_copy_and_append): Delete unused. * gfortran.h: Delete comment and extra include. * constructor.h: Bump copyright and clean up TODO comments. * resolve.c: Whitespace. 2010-04-12 Daniel Franke * simplify.c (compute_dot_product): Replaced usage of ADVANCE macro with direct access access to elements. Adjusted prototype, fixed all callers. (gfc_simplify_dot_product): Removed duplicate check for zero-sized array. (gfc_simplify_matmul): Removed usage of ADVANCE macro. (gfc_simplify_spread): Removed workaround, directly insert elements at a given array position. (gfc_simplify_transpose): Likewise. (gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding function calls. (gfc_simplify_unpack): Likewise. 2010-04-12 Daniel Franke * simplify.c (only_convert_cmplx_boz): Renamed to ... (convert_boz): ... this and moved to start of file. (gfc_simplify_abs): Whitespace fix. (gfc_simplify_acos): Whitespace fix. (gfc_simplify_acosh): Whitespace fix. (gfc_simplify_aint): Whitespace fix. (gfc_simplify_dint): Whitespace fix. (gfc_simplify_anint): Whitespace fix. (gfc_simplify_and): Replaced if-gate by more common switch-over-type. (gfc_simplify_dnint): Whitespace fix. (gfc_simplify_asin): Whitespace fix. (gfc_simplify_asinh): Moved creation of result-expr out of switch. (gfc_simplify_atan): Likewise. (gfc_simplify_atanh): Whitespace fix. (gfc_simplify_atan2): Whitespace fix. (gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED. (gfc_simplify_bessel_j1): Likewise. (gfc_simplify_bessel_jn): Likewise. (gfc_simplify_bessel_y0): Likewise. (gfc_simplify_bessel_y1): Likewise. (gfc_simplify_bessel_yn): Likewise. (gfc_simplify_ceiling): Reorderd statements. (simplify_cmplx): Use convert_boz(), check for constant arguments. Whitespace fix. (gfc_simplify_cmplx): Use correct default kind. Removed check for constant arguments. (gfc_simplify_complex): Replaced if-gate. Removed check for constant arguments. (gfc_simplify_conjg): Whitespace fix. (gfc_simplify_cos): Whitespace fix. (gfc_simplify_cosh): Replaced if-gate by more common switch-over-type. (gfc_simplify_dcmplx): Removed check for constant arguments. (gfc_simplify_dble): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_digits): Whitespace fix. (gfc_simplify_dim): Whitespace fix. (gfc_simplify_dprod): Reordered statements. (gfc_simplify_erf): Whitespace fix. (gfc_simplify_erfc): Whitespace fix. (gfc_simplify_epsilon): Whitespace fix. (gfc_simplify_exp): Whitespace fix. (gfc_simplify_exponent): Use convert_boz(). (gfc_simplify_floor): Reorderd statements. (gfc_simplify_gamma): Whitespace fix. (gfc_simplify_huge): Whitespace fix. (gfc_simplify_iand): Whitespace fix. (gfc_simplify_ieor): Whitespace fix. (simplify_intconv): Use gfc_convert_constant(). (gfc_simplify_int): Use simplify_intconv(). (gfc_simplify_int2): Reorderd statements. (gfc_simplify_idint): Reorderd statements. (gfc_simplify_ior): Whitespace fix. (gfc_simplify_ishftc): Removed duplicate type check. (gfc_simplify_len): Use range_check() instead of manual range check. (gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix. (gfc_simplify_log): Whitespace fix. (gfc_simplify_log10): Whitespace fix. (gfc_simplify_minval): Whitespace fix. (gfc_simplify_maxval): Whitespace fix. (gfc_simplify_mod): Whitespace fix. (gfc_simplify_modulo): Whitespace fix. (simplify_nint): Reorderd statements. (gfc_simplify_not): Whitespace fix. (gfc_simplify_or): Replaced if-gate by more common switch-over-type. (gfc_simplify_radix): Removed unused result-variable. Whitespace fix. (gfc_simplify_range): Removed unused result-variable. Whitespace fix. (gfc_simplify_real): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_realpart): Whitespace fix. (gfc_simplify_selected_char_kind): Removed unused result-variable. (gfc_simplify_selected_int_kind): Removed unused result-variable. (gfc_simplify_selected_real_kind): Removed unused result-variable. (gfc_simplify_sign): Whitespace fix. (gfc_simplify_sin): Whitespace fix. (gfc_simplify_sinh): Replaced if-gate by more common switch-over-type. (gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix. (gfc_simplify_tan): Replaced if-gate by more common switch-over-type. (gfc_simplify_tanh): Replaced if-gate by more common switch-over-type. (gfc_simplify_xor): Replaced if-gate by more common switch-over-type. 2010-04-12 Daniel Franke * gfortran.h (gfc_start_constructor): Removed. (gfc_get_array_element): Removed. * array.c (gfc_start_constructor): Removed, use gfc_get_array_expr instead. Fixed all callers. (extract_element): Removed. (gfc_expand_constructor): Temporarily removed check for max-array-constructor. Will be re-introduced later if still required. (gfc_get_array_element): Removed, use gfc_constructor_lookup_expr instead. Fixed all callers. * expr.c (find_array_section): Replaced manual lookup of elements by gfc_constructor_lookup. 2010-04-12 Daniel Franke * gfortran.h (gfc_get_null_expr): New prototype. (gfc_get_operator_expr): New prototype. (gfc_get_character_expr): New prototype. (gfc_get_iokind_expr): New prototype. * expr.c (gfc_get_null_expr): New. (gfc_get_character_expr): New. (gfc_get_iokind_expr): New. (gfc_get_operator_expr): Moved here from matchexp.c (build_node). * matchexp.c (build_node): Renamed and moved to expr.c (gfc_get_operator_expr). Reordered arguments to match other functions. Fixed all callers. (gfc_get_parentheses): Use specific function to build expr. * array.c (gfc_match_array_constructor): Likewise. * arith.c (eval_intrinsic): Likewise. (gfc_hollerith2int): Likewise. (gfc_hollerith2real): Likewise. (gfc_hollerith2complex): Likewise. (gfc_hollerith2logical): Likewise. * data.c (create_character_intializer): Likewise. * decl.c (gfc_match_null): Likewise. (enum_initializer): Likewise. * io.c (gfc_match_format): Likewise. (match_io): Likewise. * match.c (gfc_match_nullify): Likewise. * primary.c (match_string_constant): Likewise. (match_logical_constant): Likewise. (build_actual_constructor): Likewise. * resolve.c (build_default_init_expr): Likewise. * symbol.c (generate_isocbinding_symbol): Likewise. (gfc_build_class_symbol): Likewise. (gfc_find_derived_vtab): Likewise. * simplify.c (simplify_achar_char): Likewise. (gfc_simplify_adjustl): Likewise. (gfc_simplify_adjustr): Likewise. (gfc_simplify_and): Likewise. (gfc_simplify_bit_size): Likewise. (gfc_simplify_is_iostat_end): Likewise. (gfc_simplify_is_iostat_eor): Likewise. (gfc_simplify_isnan): Likewise. (simplify_bound): Likewise. (gfc_simplify_leadz): Likewise. (gfc_simplify_len_trim): Likewise. (gfc_simplify_logical): Likewise. (gfc_simplify_maxexponent): Likewise. (gfc_simplify_minexponent): Likewise. (gfc_simplify_new_line): Likewise. (gfc_simplify_null): Likewise. (gfc_simplify_or): Likewise. (gfc_simplify_precision): Likewise. (gfc_simplify_repeat): Likewise. (gfc_simplify_scan): Likewise. (gfc_simplify_size): Likewise. (gfc_simplify_trailz): Likewise. (gfc_simplify_trim): Likewise. (gfc_simplify_verify): Likewise. (gfc_simplify_xor): Likewise. * trans-io.c (build_dt): Likewise. (gfc_new_nml_name_expr): Removed. 2010-04-12 Daniel Franke * arith.h (gfc_constant_result): Removed prototype. * constructor.h (gfc_build_array_expr): Removed prototype. (gfc_build_structure_constructor_expr): Removed prototype. * gfortran.h (gfc_int_expr): Removed prototype. (gfc_logical_expr): Removed prototype. (gfc_get_array_expr): New prototype. (gfc_get_structure_constructor_expr): New prototype. (gfc_get_constant_expr): New prototype. (gfc_get_int_expr): New prototype. (gfc_get_logical_expr): New prototype. * arith.c (gfc_constant_result): Moved and renamed to expr.c (gfc_get_constant_expr). Fixed all callers. * constructor.c (gfc_build_array_expr): Moved and renamed to expr.c (gfc_get_array_expr). Split gfc_typespec argument to type and kind. Fixed all callers. (gfc_build_structure_constructor_expr): Moved and renamed to expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument to type and kind. Fixed all callers. * expr.c (gfc_logical_expr): Renamed to ... (gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers. (gfc_int_expr): Renamed to ... (gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all callers. (gfc_get_constant_expr): New. (gfc_get_array_expr): New. (gfc_get_structure_constructor_expr): New. * simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr instead. 2010-04-12 Daniel Franke * constructor.h: New. * constructor.c: New. * Make-lang.in: Add new files to F95_PARSER_OBJS. * arith.c (reducy_unary): Use constructor API. (reduce_binary_ac): Likewise. (reduce_binary_ca): Likewise. (reduce_binary_aa): Likewise. * check.c (gfc_check_pack): Likewise. (gfc_check_reshape): Likewise. (gfc_check_unpack): Likewise. * decl.c (add_init_expr_to_sym): Likewise. (build_struct): Likewise. * dependency.c (gfc_check_dependency): Likewise. (contains_forall_index_p): Likewise. * dump-parse-tree.c (show_constructor): Likewise. * expr.c (free_expr0): Likewise. (gfc_copy_expr): Likewise. (gfc_is_constant_expr): Likewise. (simplify_constructor): Likewise. (find_array_element): Likewise. (find_component_ref): Likewise. (find_array_section): Likewise. (find_substring_ref): Likewise. (simplify_const_ref): Likewise. (scalarize_intrinsic_call): Likewise. (check_alloc_comp_init): Likewise. (gfc_default_initializer): Likewise. (gfc_traverse_expr): Likewise. * iresolve.c (check_charlen_present): Likewise. (gfc_resolve_reshape): Likewise. (gfc_resolve_transfer): Likewise. * module.c (mio_constructor): Likewise. * primary.c (build_actual_constructor): Likewise. (gfc_match_structure_constructor): Likewise. * resolve.c (resolve_structure_cons): Likewise. * simplify.c (is_constant_array_expr): Likewise. (init_result_expr): Likewise. (transformational_result): Likewise. (simplify_transformation_to_scalar): Likewise. (simplify_transformation_to_array): Likewise. (gfc_simplify_dot_product): Likewise. (simplify_bound): Likewise. (simplify_matmul): Likewise. (simplify_minval_maxval): Likewise. (gfc_simplify_pack): Likewise. (gfc_simplify_reshape): Likewise. (gfc_simplify_shape): Likewise. (gfc_simplify_spread): Likewise. (gfc_simplify_transpose): Likewise. (gfc_simplify_unpack): Likewise.q (gfc_convert_constant): Likewise. (gfc_convert_char_constant): Likewise. * target-memory.c (size_array): Likewise. (encode_array): Likewise. (encode_derived): Likewise. (interpret_array): Likewise. (gfc_interpret_derived): Likewise. (expr_to_char): Likewise. (gfc_merge_initializers): Likewise. * trans-array.c (gfc_get_array_constructor_size): Likewise. (gfc_trans_array_constructor_value): Likewise. (get_array_ctor_strlen): Likewise. (gfc_constant_array_constructor_p): Likewise. (gfc_build_constant_array_constructor): Likewise. (gfc_trans_array_constructor): Likewise. (gfc_conv_array_initializer): Likewise. * trans-decl.c (check_constant_initializer): Likewise. * trans-expr.c (flatten_array_ctors_without_strlen): Likewise. (gfc_apply_interface_mapping_to_cons): Likewise. (gfc_trans_structure_assign): Likewise. (gfc_conv_structure): Likewise. * array.c (check_duplicate_iterator): Likewise. (match_array_list): Likewise. (match_array_cons_element): Likewise. (gfc_match_array_constructor): Likewise. (check_constructor_type): Likewise. (check_constructor): Likewise. (expand): Likewise. (expand_constructor): Likewise. (extract_element): Likewise. (gfc_expanded_ac): Likewise. (resolve_array_list): Likewise. (gfc_resolve_character_array_constructor): Likewise. (copy_iterator): Renamed to ... (gfc_copy_iterator): ... this. (gfc_append_constructor): Removed. (gfc_insert_constructor): Removed unused function. (gfc_get_constructor): Removed. (gfc_free_constructor): Removed. (qgfc_copy_constructor): Removed. * gfortran.h (struct gfc_expr): Removed member 'con_by_offset'. Removed all references. Replaced constructor list by splay-tree. (struct gfc_constructor): Removed member 'next', moved 'offset' from the inner struct, added member 'base'. (gfc_append_constructor): Removed prototype. (gfc_insert_constructor): Removed prototype. (gfc_get_constructor): Removed prototype. (gfc_free_constructor): Removed prototype. (qgfc_copy_constructor): Removed prototype. (gfc_copy_iterator): New prototype. * trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158253 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 55 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 32 insertions(+), 23 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5e9b25c8a16..2831149c757 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" #include "data.h" #include "target-memory.h" /* for gfc_simplify_transfer */ +#include "constructor.h" /* Types used in equivalence statements. */ @@ -227,7 +228,8 @@ resolve_formal_arglist (gfc_symbol *proc) { sym->as->type = AS_ASSUMED_SHAPE; for (i = 0; i < sym->as->rank; i++) - sym->as->lower[i] = gfc_int_expr (1); + sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); } if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) @@ -841,7 +843,7 @@ resolve_structure_cons (gfc_expr *expr) symbol_attribute a; t = SUCCESS; - cons = expr->value.constructor; + cons = gfc_constructor_first (expr->value.constructor); /* A constructor may have references if it is the result of substituting a parameter variable. In this case we just pull out the component we want. */ @@ -867,7 +869,7 @@ resolve_structure_cons (gfc_expr *expr) && cons->expr && cons->expr->expr_type == EXPR_NULL) return SUCCESS; - for (; comp; comp = comp->next, cons = cons->next) + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { int rank; @@ -4309,7 +4311,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); else - start = gfc_int_expr (1); + start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); if (char_ref->u.ss.end) end = gfc_copy_expr (char_ref->u.ss.end); @@ -4323,7 +4325,9 @@ gfc_resolve_substring_charlen (gfc_expr *e) /* Length = (end - start +1). */ e->ts.u.cl->length = gfc_subtract (end, start); - e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1)); + e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, + gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1)); e->ts.u.cl->length->ts.type = BT_INTEGER; e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; @@ -4820,12 +4824,14 @@ gfc_resolve_character_operator (gfc_expr *e) if (op1->ts.u.cl && op1->ts.u.cl->length) e1 = gfc_copy_expr (op1->ts.u.cl->length); else if (op1->expr_type == EXPR_CONSTANT) - e1 = gfc_int_expr (op1->value.character.length); + e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + op1->value.character.length); if (op2->ts.u.cl && op2->ts.u.cl->length) e2 = gfc_copy_expr (op2->ts.u.cl->length); else if (op2->expr_type == EXPR_CONSTANT) - e2 = gfc_int_expr (op2->value.character.length); + e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + op2->value.character.length); e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -5690,15 +5696,16 @@ gfc_is_expandable_expr (gfc_expr *e) /* Traverse the constructor looking for variables that are flavor parameter. Parameters must be expanded since they are fully used at compile time. */ - for (con = e->value.constructor; con; con = con->next) + con = gfc_constructor_first (e->value.constructor); + for (; con; con = gfc_constructor_next (con)) { if (con->expr->expr_type == EXPR_VARIABLE - && con->expr->symtree - && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER + && con->expr->symtree + && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) return true; if (con->expr->expr_type == EXPR_ARRAY - && gfc_is_expandable_expr (con->expr)) + && gfc_is_expandable_expr (con->expr)) return true; } } @@ -7282,12 +7289,14 @@ resolve_select_type (gfc_code *code) for (body = code->block; body; body = body->block) { c = body->ext.case_list; - + if (c->ts.type == BT_DERIVED) - c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value); + c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c->ts.u.derived->hash_value); + else if (c->ts.type == BT_UNKNOWN) continue; - + /* Assign temporary to selector. */ if (c->ts.type == BT_CLASS) sprintf (name, "tmp$class$%s", c->ts.u.derived->name); @@ -7543,7 +7552,8 @@ resolve_sync (gfc_code *code) && gfc_simplify_expr (code->expr1, 0) == SUCCESS) { gfc_constructor *cons; - for (cons = code->expr1->value.constructor; cons; cons = cons->next) + cons = gfc_constructor_first (code->expr1->value.constructor); + for (; cons; cons = gfc_constructor_next (cons)) if (cons->expr->expr_type == EXPR_CONSTANT && mpz_cmp_si (cons->expr->value.integer, 1) < 0) gfc_error ("Imageset argument at %L must between 1 and " @@ -8895,7 +8905,8 @@ resolve_charlen (gfc_charlen *cl) gfc_warning_now ("CHARACTER variable at %L has negative length %d," " the length has been set to zero", &cl->length->where, i); - gfc_replace_expr (cl->length, gfc_int_expr (0)); + gfc_replace_expr (cl->length, + gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); } /* Check that the character length is not too large. */ @@ -9027,12 +9038,9 @@ build_default_init_expr (gfc_symbol *sym) return NULL; /* Now we'll try to build an initializer expression. */ - init_expr = gfc_get_expr (); - init_expr->expr_type = EXPR_CONSTANT; - init_expr->ts.type = sym->ts.type; - init_expr->ts.kind = sym->ts.kind; - init_expr->where = sym->declared_at; - + init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind, + &sym->declared_at); + /* We will only initialize integers, reals, complex, logicals, and characters, and only if the corresponding command-line flags were set. Otherwise, we free init_expr and return null. */ @@ -12398,7 +12406,8 @@ resolve_equivalence (gfc_equiv *eq) { ref->type = REF_SUBSTRING; if (start == NULL) - start = gfc_int_expr (1); + start = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); ref->u.ss.start = start; if (end == NULL && e->ts.u.cl) end = gfc_copy_expr (e->ts.u.cl->length); -- cgit v1.2.1 From cf4b41d8941566369379a8bcf992411b11748fbb Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 20 Apr 2010 19:07:14 +0000 Subject: 2010-04-20 Paul Thomas PR fortran/43227 * resolve.c (resolve_fl_derived): If a component character length has not been resolved, do so now. (resolve_symbol): The same as above for a symbol character length. * trans-decl.c (gfc_create_module_variable): A 'length' decl is not needed for a character valued, procedure pointer. PR fortran/43266 * resolve.c (ensure_not_abstract_walker): If 'overriding' is not found, return FAILURE rather than ICEing. 2010-04-20 Paul Thomas PR fortran/43227 * gfortran.dg/proc_decl_23.f90: New test. PR fortran/43266 * gfortran.dg/abstract_type_6.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158570 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2831149c757..b13edf98e1f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10617,7 +10617,9 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) { gfc_symtree* overriding; overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); - gcc_assert (overriding && overriding->n.tb); + if (!overriding) + return FAILURE; + gcc_assert (overriding->n.tb); if (overriding->n.tb->deferred) { gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because" @@ -10784,8 +10786,12 @@ resolve_fl_derived (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - gfc_expr_replace_comp (c->ts.u.cl->length, c); + gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + gfc_expr_replace_comp (cl->length, c); + if (cl->length && !cl->resolved + && gfc_resolve_expr (cl->length) == FAILURE) + return FAILURE; + c->ts.u.cl = cl; } } else if (c->ts.interface->name[0] != '\0') @@ -11298,6 +11304,9 @@ resolve_symbol (gfc_symbol *sym) { sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); gfc_expr_replace_symbols (sym->ts.u.cl->length, sym); + if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved + && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE) + return; } } else if (sym->ts.interface->name[0] != '\0') -- cgit v1.2.1 From e2ab564d100612d6415ce2dc2e7dc19024ae2bc7 Mon Sep 17 00:00:00 2001 From: rguenth Date: Thu, 22 Apr 2010 08:34:41 +0000 Subject: 2010-04-22 Richard Guenther PR fortran/43829 * resolve.c (gfc_resolve_index): Wrap around ... (gfc_resolve_index_1): ... this. Add parameter to allow any integer kind index type. (resolve_array_ref): Allow any integer kind for the start index of an array ref. * gfortran.dg/vector_subscript_6.f90: New testcase. * gfortran.dg/assign_10.f90: Adjust. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158632 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b13edf98e1f..aeccffb60ca 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3978,8 +3978,9 @@ compare_spec_to_ref (gfc_array_ref *ar) /* Resolve one part of an array index. */ -gfc_try -gfc_resolve_index (gfc_expr *index, int check_scalar) +static gfc_try +gfc_resolve_index_1 (gfc_expr *index, int check_scalar, + int force_index_integer_kind) { gfc_typespec ts; @@ -4007,7 +4008,8 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) &index->where) == FAILURE) return FAILURE; - if (index->ts.kind != gfc_index_integer_kind + if ((index->ts.kind != gfc_index_integer_kind + && force_index_integer_kind) || index->ts.type != BT_INTEGER) { gfc_clear_ts (&ts); @@ -4020,6 +4022,14 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) return SUCCESS; } +/* Resolve one part of an array index. */ + +gfc_try +gfc_resolve_index (gfc_expr *index, int check_scalar) +{ + return gfc_resolve_index_1 (index, check_scalar, 1); +} + /* Resolve a dim argument to an intrinsic function. */ gfc_try @@ -4144,7 +4154,10 @@ resolve_array_ref (gfc_array_ref *ar) { check_scalar = ar->dimen_type[i] == DIMEN_RANGE; - if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE) + /* Do not force gfc_index_integer_kind for the start. We can + do fine with any integer kind. This avoids temporary arrays + created for indexing with a vector. */ + if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE) return FAILURE; if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE) return FAILURE; -- cgit v1.2.1 From 6ddcd499e191351f9cf850c4a7d23eb6ad3ca4de Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 27 Apr 2010 08:41:00 +0000 Subject: 2010-04-27 Tobias Burnus PR fortran/18918 * resolve.c (resolve_allocate_expr): Allow array coarrays. * trans-types.h (gfc_get_array_type_bounds): Update prototype. * trans-types.c (gfc_get_array_type_bounds, gfc_get_array_descriptor_base): Add corank argument. * trans-array.c (gfc_array_init_size): Handle corank. (gfc_trans_create_temp_array, gfc_array_allocate, gfc_conv_expr_descriptor): Add corank argument to call. * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto. 2010-04-27 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_7.f90: Modified and removed obsolete tests. * gfortran.dg/coarray_12.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158768 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index aeccffb60ca..135eda4d53b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6561,9 +6561,9 @@ check_symbols: goto failure; } - if (codimension) + if (codimension && ar->as->rank == 0) { - gfc_error ("Sorry, allocatable coarrays are no yet supported coarray " + gfc_error ("Sorry, allocatable scalar coarrays are not yet supported " "at %L", &e->where); goto failure; } -- cgit v1.2.1 From 09c509edcc2f6e6859f02de43ce0fe10a941a8d7 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 29 Apr 2010 19:10:48 +0000 Subject: 2010-04-29 Janus Weil PR fortran/43896 * symbol.c (add_proc_component,copy_vtab_proc_comps): Remove initializers for PPC members of the vtabs. 2010-04-29 Janus Weil PR fortran/42274 * symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc' attribute for all PPC members of the vtypes. (copy_vtab_proc_comps): Copy the correct interface. * trans.h (gfc_trans_assign_vtab_procs): Modified prototype. * trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as a dummy argument and make sure all PPC members of the vtab are initialized correctly. (gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument in call to gfc_trans_assign_vtab_procs. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-04-29 Paul Thomas PR fortran/43326 * resolve.c (resolve_typebound_function): Renamed resolve_class_compcall.Do all the detection of class references here. (resolve_typebound_subroutine): resolve_class_typebound_call renamed. Otherwise same as resolve_typebound_function. (gfc_resolve_expr): Call resolve_typebound_function. (resolve_code): Call resolve_typebound_subroutine. 2010-04-29 Janus Weil PR fortran/43492 * resolve.c (resolve_typebound_generic_call): For CLASS methods pass back the specific symtree name, rather than the target name. 2010-04-29 Paul Thomas PR fortran/42353 * resolve.c (resolve_structure_cons): Make the initializer of the vtab component 'extends' the same type as the component. 2010-04-29 Jerry DeLisle PR fortran/42680 * interface.c (check_interface1): Pass symbol name rather than NULL to gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to trap MULL. (gfc_compare_derived_types): Revert previous change incorporated incorrectly during merge from trunk, r155778. * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather than NULL to gfc_compare_interfaces. * symbol.c (add_generic_specifics): Likewise. 2010-02-29 Janus Weil PR fortran/42353 * interface.c (gfc_compare_derived_types): Add condition for vtype. * symbol.c (gfc_find_derived_vtab): Sey access to private. (gfc_find_derived_vtab): Likewise. * module.c (ab_attribute): Add enumerator AB_VTAB. (mio_symbol_attribute): Use new attribute, AB_VTAB. (check_for_ambiguous): Likewise. 2010-04-29 Paul Thomas Janus Weil PR fortran/41829 * trans-expr.c (select_class_proc): Remove function. (conv_function_val): Delete reference to previous. (gfc_conv_derived_to_class): Add second argument to the call to gfc_find_derived_vtab. (gfc_conv_structure): Exclude proc_pointer components when accessing $data field of class objects. (gfc_trans_assign_vtab_procs): New function. (gfc_trans_class_assign): Add second argument to the call to gfc_find_derived_vtab. * symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and implement holding off searching for the vptr derived type. (add_proc_component): New function. (add_proc_comps): New function. (add_procs_to_declared_vtab1): New function. (copy_vtab_proc_comps): New function. (add_procs_to_declared_vtab): New function. (void add_generic_specifics): New function. (add_generics_to_declared_vtab): New function. (gfc_find_derived_vtab): Add second argument to the call to gfc_find_derived_vtab. Add the calls to add_procs_to_declared_vtab and add_generics_to_declared_vtab. * decl.c (build_sym, build_struct): Use new arg in calls to gfc_build_class_symbol. * gfortran.h : Add vtype bitfield to symbol_attr. Remove the definition of struct gfc_class_esym_list. Modify prototypes of gfc_build_class_symbol and gfc_find_derived_vtab. * trans-stmt.c (gfc_trans_allocate): Add second argument to the call to gfc_find_derived_vtab. * module.c : Add the vtype attribute. * trans.h : Add prototype for gfc_trans_assign_vtab_procs. * resolve.c (resolve_typebound_generic_call): Add second arg to pass along the generic name for class methods. (resolve_typebound_call): The same. (resolve_compcall): Use the second arg to carry the generic name from the above. Remove the reference to class_esym. (check_members, check_class_members, resolve_class_esym, hash_value_expr): Remove functions. (resolve_class_compcall, resolve_class_typebound_call): Modify to use vtable rather than member by member calls. (gfc_resolve_expr): Modify second arg in call to resolve_compcall. (resolve_select_type): Add second arg in call to gfc_find_derived_vtab. (resolve_code): Add second arg in call resolve_typebound_call. (resolve_fl_derived): Exclude vtypes from check for late procedure definitions. Likewise for checking of explicit interface and checking of pass arg. * iresolve.c (gfc_resolve_extends_type_of): Add second arg in calls to gfc_find_derived_vtab. * match.c (select_type_set_tmp): Use new arg in call to gfc_build_class_symbol. * trans-decl.c (gfc_get_symbol_decl): Complete vtable if necessary. * parse.c (endType): Finish incomplete classes. 2010-04-29 Janus Weil PR fortran/42274 * gfortran.dg/class_16.f03: New test. 2010-04-29 Janus Weil PR fortran/42274 * gfortran.dg/class_15.f03: New. 2010-04-29 Paul Thomas PR fortran/43326 * gfortran.dg/dynamic_dispatch_9.f03: New test. 2010-04-29 Janus Weil PR fortran/43492 * gfortran.dg/generic_22.f03 : New test. 2010-04-29 Paul Thomas PR fortran/42353 * gfortran.dg/class_14.f03: New test. 2010-04-29 Jerry DeLisle PR fortran/42680 * gfortran.dg/interface_32.f90: New test. 2009-04-29 Paul Thomas Janus Weil PR fortran/41829 * gfortran.dg/dynamic_dispatch_5.f03 : Change to "run". * gfortran.dg/dynamic_dispatch_7.f03 : New test. * gfortran.dg/dynamic_dispatch_8.f03 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158910 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 404 +++++++++++++++++--------------------------------- 1 file changed, 133 insertions(+), 271 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 135eda4d53b..93c5b484ce0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -898,7 +898,15 @@ resolve_structure_cons (gfc_expr *expr) if (!gfc_compare_types (&cons->expr->ts, &comp->ts)) { t = FAILURE; - if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) + if (strcmp (comp->name, "$extends") == 0) + { + /* Can afford to be brutal with the $extends initializer. + The derived type can get lost because it is PRIVATE + but it is not usage constrained by the standard. */ + cons->expr->ts = comp->ts; + t = SUCCESS; + } + else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) gfc_error ("The element in the derived type constructor at %L, " "for pointer component '%s', is %s but should be %s", &cons->expr->where, comp->name, @@ -1874,13 +1882,12 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Non-assumed length character functions. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl != NULL - && gsym->ns->proc_name->ts.u.cl->length != NULL) + && gsym->ns->proc_name->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) { gfc_error ("Nonconstant character-length function '%s' at %L " "must have an explicit interface", sym->name, @@ -5121,7 +5128,7 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, the expression into a call of that binding. */ static gfc_try -resolve_typebound_generic_call (gfc_expr* e) +resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; @@ -5177,6 +5184,10 @@ resolve_typebound_generic_call (gfc_expr* e) if (matches) { e->value.compcall.tbp = g->specific; + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = g->specific_st->name; goto success; } } @@ -5195,7 +5206,7 @@ success: /* Resolve a call to a type-bound subroutine. */ static gfc_try -resolve_typebound_call (gfc_code* c) +resolve_typebound_call (gfc_code* c, const char **name) { gfc_actual_arglist* newactual; gfc_symtree* target; @@ -5211,7 +5222,12 @@ resolve_typebound_call (gfc_code* c) if (check_typebound_baseobject (c->expr1) == FAILURE) return FAILURE; - if (resolve_typebound_generic_call (c->expr1) == FAILURE) + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = c->expr1->value.compcall.name; + + if (resolve_typebound_generic_call (c->expr1, name) == FAILURE) return FAILURE; /* Transform into an ordinary EXEC_CALL for now. */ @@ -5235,31 +5251,20 @@ resolve_typebound_call (gfc_code* c) } -/* Resolve a component-call expression. This originally was intended - only to see functions. However, it is convenient to use it in - resolving subroutine class methods, since we do not have to add a - gfc_code each time. */ +/* Resolve a component-call expression. */ static gfc_try -resolve_compcall (gfc_expr* e, bool fcn, bool class_members) +resolve_compcall (gfc_expr* e, const char **name) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a FUNCTION. */ - if (fcn && !e->value.compcall.tbp->function) + if (!e->value.compcall.tbp->function) { gfc_error ("'%s' at %L should be a FUNCTION", e->value.compcall.name, &e->where); return FAILURE; } - else if (!fcn && !e->value.compcall.tbp->subroutine) - { - /* To resolve class member calls, we borrow this bit - of code to select the specific procedures. */ - gfc_error ("'%s' at %L should be a SUBROUTINE", - e->value.compcall.name, &e->where); - return FAILURE; - } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); @@ -5267,7 +5272,12 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) if (check_typebound_baseobject (e) == FAILURE) return FAILURE; - if (resolve_typebound_generic_call (e) == FAILURE) + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = e->value.compcall.name; + + if (resolve_typebound_generic_call (e, name) == FAILURE) return FAILURE; gcc_assert (!e->value.compcall.tbp->is_generic); @@ -5284,169 +5294,15 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) e->value.function.actual = newactual; e->value.function.name = NULL; e->value.function.esym = target->n.sym; - e->value.function.class_esym = NULL; e->value.function.isym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; - /* Resolution is not necessary when constructing component calls - for class members, since this must only be done for the - declared type, which is done afterwards. */ - return !class_members ? gfc_resolve_expr (e) : SUCCESS; -} - - -/* Resolve a typebound call for the members in a class. This group of - functions implements dynamic dispatch in the provisional version - of f03 OOP. As soon as vtables are in place and contain pointers - to methods, this will no longer be necessary. */ -static gfc_expr *list_e; -static gfc_try check_class_members (gfc_symbol *); -static gfc_try class_try; -static bool fcn_flag; - - -static void -check_members (gfc_symbol *derived) -{ - if (derived->attr.flavor == FL_DERIVED) - (void) check_class_members (derived); -} - - -static gfc_try -check_class_members (gfc_symbol *derived) -{ - gfc_expr *e; - gfc_symtree *tbp; - gfc_class_esym_list *etmp; - - e = gfc_copy_expr (list_e); - - tbp = gfc_find_typebound_proc (derived, &class_try, - e->value.compcall.name, - false, &e->where); - - if (tbp == NULL) - { - gfc_error ("no typebound available procedure named '%s' at %L", - e->value.compcall.name, &e->where); - return FAILURE; - } - - /* If we have to match a passed class member, force the actual - expression to have the correct type. */ - if (!tbp->n.tb->nopass) - { - if (e->value.compcall.base_object == NULL) - e->value.compcall.base_object = extract_compcall_passed_object (e); - - if (e->value.compcall.base_object == NULL) - return FAILURE; - - if (!derived->attr.abstract) - { - e->value.compcall.base_object->ts.type = BT_DERIVED; - e->value.compcall.base_object->ts.u.derived = derived; - } - } - - e->value.compcall.tbp = tbp->n.tb; - e->value.compcall.name = tbp->name; - - /* Let the original expresssion catch the assertion in - resolve_compcall, since this flag does not appear to be reset or - copied in some systems. */ - e->value.compcall.assign = 0; - - /* Do the renaming, PASSing, generic => specific and other - good things for each class member. */ - class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS) - ? class_try : FAILURE; - - /* Now transfer the found symbol to the esym list. */ - if (class_try == SUCCESS) - { - etmp = list_e->value.function.class_esym; - list_e->value.function.class_esym - = gfc_get_class_esym_list(); - list_e->value.function.class_esym->next = etmp; - list_e->value.function.class_esym->derived = derived; - list_e->value.function.class_esym->esym - = e->value.function.esym; - } - - gfc_free_expr (e); - - /* Burrow down into grandchildren types. */ - if (derived->f2k_derived) - gfc_traverse_ns (derived->f2k_derived, check_members); - - return SUCCESS; -} - - -/* Eliminate esym_lists where all the members point to the - typebound procedure of the declared type; ie. one where - type selection has no effect.. */ -static void -resolve_class_esym (gfc_expr *e) -{ - gfc_class_esym_list *p, *q; - bool empty = true; - - gcc_assert (e && e->expr_type == EXPR_FUNCTION); - - p = e->value.function.class_esym; - if (p == NULL) - return; - - for (; p; p = p->next) - empty = empty && (e->value.function.esym == p->esym); - - if (empty) - { - p = e->value.function.class_esym; - for (; p; p = q) - { - q = p->next; - gfc_free (p); - } - e->value.function.class_esym = NULL; - } -} - - -/* Generate an expression for the hash value, given the reference to - the class of the final expression (class_ref), the base of the - full reference list (new_ref), the declared type and the class - object (st). */ -static gfc_expr* -hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st) -{ - gfc_expr *hash_value; - - /* Build an expression for the correct hash_value; ie. that of the last - CLASS reference. */ - if (class_ref) - { - class_ref->next = NULL; - } - else - { - gfc_free_ref_list (new_ref); - new_ref = NULL; - } - hash_value = gfc_get_expr (); - hash_value->expr_type = EXPR_VARIABLE; - hash_value->symtree = st; - hash_value->symtree->n.sym->refs++; - hash_value->ref = new_ref; - gfc_add_component_ref (hash_value, "$vptr"); - gfc_add_component_ref (hash_value, "$hash"); - - return hash_value; + /* Resolution is not necessary if this is a class subroutine; this + function only has to identify the specific proc. Resolution of + the call will be done next in resolve_typebound_call. */ + return gfc_resolve_expr (e); } @@ -5483,146 +5339,151 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, } -/* Resolve the argument expressions so that any arguments expressions - that include class methods are resolved before the current call. - This is necessary because of the static variables used in CLASS - method resolution. */ -static void -resolve_arg_exprs (gfc_actual_arglist *arg) -{ - /* Resolve the actual arglist expressions. */ - for (; arg; arg = arg->next) - { - if (arg->expr) - gfc_resolve_expr (arg->expr); - } -} - - -/* Resolve a typebound function, or 'method'. First separate all - the non-CLASS references by calling resolve_compcall directly. - Then treat the CLASS references by resolving for each of the class - members in turn. */ +/* Resolve a typebound function, or 'method'. First separate all + the non-CLASS references by calling resolve_compcall directly. */ static gfc_try resolve_typebound_function (gfc_expr* e) { - gfc_symbol *derived, *declared; + gfc_symbol *declared; + gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; + const char *name; + const char *genname; + gfc_typespec ts; st = e->symtree; if (st == NULL) - return resolve_compcall (e, true, false); + return resolve_compcall (e, NULL); /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); - return resolve_compcall (e, true, false); + return resolve_compcall (e, NULL); } - /* Resolve the argument expressions, */ - resolve_arg_exprs (e->value.function.actual); + c = gfc_find_component (declared, "$data", true, true); + declared = c->ts.u.derived; - /* Get the data component, which is of the declared type. */ - derived = declared->components->ts.u.derived; + /* Keep the generic name so that the vtab reference can be made. */ + genname = NULL; + if (e->value.compcall.tbp->is_generic) + genname = e->value.compcall.name; - /* Resolve the function call for each member of the class. */ - class_try = SUCCESS; - fcn_flag = true; - list_e = gfc_copy_expr (e); - - if (check_class_members (derived) == FAILURE) - return FAILURE; + /* Treat the call as if it is a typebound procedure, in order to roll + out the correct name for the specific function. */ + resolve_compcall (e, &name); + ts = e->ts; - class_try = (resolve_compcall (e, true, false) == SUCCESS) - ? class_try : FAILURE; + /* Then convert the expression to a procedure pointer component call. */ + e->value.function.esym = NULL; + e->symtree = st; - /* Transfer the class list to the original expression. Note that - the class_esym list is cleaned up in trans-expr.c, as the calls - are translated. */ - e->value.function.class_esym = list_e->value.function.class_esym; - list_e->value.function.class_esym = NULL; - gfc_free_expr (list_e); - - resolve_class_esym (e); + if (class_ref) + { + gfc_free_ref_list (class_ref->next); + e->ref = new_ref; + } - /* More than one typebound procedure so transmit an expression for - the hash_value as the selector. */ - if (e->value.function.class_esym != NULL) - e->value.function.class_esym->hash_value - = hash_value_expr (class_ref, new_ref, st); + /* '$vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_component_ref (e, "$vptr"); + if (genname) + { + /* A generic procedure needs the subsidiary vtabs and vtypes for + the specific procedures to have been build. */ + gfc_symbol *vtab; + vtab = gfc_find_derived_vtab (declared, true); + gcc_assert (vtab); + gfc_add_component_ref (e, genname); + } + gfc_add_component_ref (e, name); - return class_try; + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + e->ts = ts; + return SUCCESS; } -/* Resolve a typebound subroutine, or 'method'. First separate all - the non-CLASS references by calling resolve_typebound_call directly. - Then treat the CLASS references by resolving for each of the class - members in turn. */ +/* Resolve a typebound subroutine, or 'method'. First separate all + the non-CLASS references by calling resolve_typebound_call + directly. */ static gfc_try resolve_typebound_subroutine (gfc_code *code) { - gfc_symbol *derived, *declared; + gfc_symbol *declared; + gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; + const char *genname; + const char *name; + gfc_typespec ts; st = code->expr1->symtree; if (st == NULL) - return resolve_typebound_call (code); + return resolve_typebound_call (code, NULL); /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); - return resolve_typebound_call (code); + return resolve_typebound_call (code, NULL); } - /* Resolve the argument expressions, */ - resolve_arg_exprs (code->expr1->value.compcall.actual); - - /* Get the data component, which is of the declared type. */ - derived = declared->components->ts.u.derived; + c = gfc_find_component (declared, "$data", true, true); + declared = c->ts.u.derived; - class_try = SUCCESS; - fcn_flag = false; - list_e = gfc_copy_expr (code->expr1); - - if (check_class_members (derived) == FAILURE) - return FAILURE; + /* Keep the generic name so that the vtab reference can be made. */ + genname = NULL; + if (code->expr1->value.compcall.tbp->is_generic) + genname = code->expr1->value.compcall.name; - class_try = (resolve_typebound_call (code) == SUCCESS) - ? class_try : FAILURE; + resolve_typebound_call (code, &name); + ts = code->expr1->ts; - /* Transfer the class list to the original expression. Note that - the class_esym list is cleaned up in trans-expr.c, as the calls - are translated. */ - code->expr1->value.function.class_esym - = list_e->value.function.class_esym; - list_e->value.function.class_esym = NULL; - gfc_free_expr (list_e); + /* Then convert the expression to a procedure pointer component call. */ + code->expr1->value.function.esym = NULL; + code->expr1->symtree = st; - resolve_class_esym (code->expr1); + if (class_ref) + { + gfc_free_ref_list (class_ref->next); + code->expr1->ref = new_ref; + } - /* More than one typebound procedure so transmit an expression for - the hash_value as the selector. */ - if (code->expr1->value.function.class_esym != NULL) - code->expr1->value.function.class_esym->hash_value - = hash_value_expr (class_ref, new_ref, st); + /* '$vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_component_ref (code->expr1, "$vptr"); + if (genname) + { + /* A generic procedure needs the subsidiary vtabs and vtypes for + the specific procedures to have been build. */ + gfc_symbol *vtab; + vtab = gfc_find_derived_vtab (declared, true); + gcc_assert (vtab); + gfc_add_component_ref (code->expr1, genname); + } + gfc_add_component_ref (code->expr1, name); - return class_try; + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + code->expr1->ts = ts; + return SUCCESS; } @@ -7372,7 +7233,7 @@ resolve_select_type (gfc_code *code) tail->next = NULL; default_case = tail; } - + /* More than one CLASS IS block? */ if (class_is->block) { @@ -7428,7 +7289,7 @@ resolve_select_type (gfc_code *code) new_st->expr1->value.function.actual = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); - vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -10743,7 +10604,7 @@ resolve_fl_derived (gfc_symbol *sym) if (c->attr.proc_pointer && c->ts.interface) { - if (c->ts.interface->attr.procedure) + if (c->ts.interface->attr.procedure && !sym->attr.vtype) gfc_error ("Interface '%s', used by procedure pointer component " "'%s' at %L, is declared in a later PROCEDURE statement", c->ts.interface->name, c->name, &c->loc); @@ -10807,7 +10668,7 @@ resolve_fl_derived (gfc_symbol *sym) c->ts.u.cl = cl; } } - else if (c->ts.interface->name[0] != '\0') + else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype) { gfc_error ("Interface '%s' of procedure pointer component " "'%s' at %L must be explicit", c->ts.interface->name, @@ -10823,7 +10684,8 @@ resolve_fl_derived (gfc_symbol *sym) } /* Procedure pointer components: Check PASS arg. */ - if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0) + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 + && !sym->attr.vtype) { gfc_symbol* me_arg; -- cgit v1.2.1 From 35820014157910c5bf152c8f20a48d01fcff064c Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 5 May 2010 07:44:33 +0000 Subject: 2010-05-05 Janus Weil PR fortran/43696 * resolve.c (resolve_fl_derived): Some fixes for class variables. * symbol.c (gfc_build_class_symbol): Add separate class container for class pointers. 2010-05-05 Janus Weil PR fortran/43696 * gfortran.dg/class_17.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159056 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 93c5b484ce0..d92c69c030c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10794,7 +10794,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ - if (super_type + if (super_type && !sym->attr.is_class && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component '%s' of '%s' at %L has the same name as an" @@ -10841,7 +10841,7 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (c->ts.type == BT_DERIVED && c->attr.pointer + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { @@ -10851,6 +10851,16 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer + && c->ts.u.derived->components->ts.u.derived->components == NULL + && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp) + { + gfc_error ("The pointer component '%s' of '%s' at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return FAILURE; + } + /* C437. */ if (c->ts.type == BT_CLASS && !(c->ts.u.derived->components->attr.pointer -- cgit v1.2.1 From 53ee584785ce94d834c0679ed8a6abb6a7c89e99 Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 5 May 2010 18:53:23 +0000 Subject: gcc/fortran/: 2010-05-05 Daniel Franke PR fortran/24978 * gfortran.h: Removed repeat count from constructor, removed all usages. * data.h (gfc_assign_data_value_range): Changed return value from void to gfc_try. * data.c (gfc_assign_data_value): Add location to constructor element. (gfc_assign_data_value_range): Call gfc_assign_data_value() for each element in range. Return early if an error was generated. * resolve.c (check_data_variable): Stop early if range assignment generated an error. gcc/testsuite/: 2010-05-05 Daniel Franke PR fortran/24978 * gfortran.dg/data_invalid.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159076 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d92c69c030c..2c79863a718 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11781,11 +11781,14 @@ check_data_variable (gfc_data_variable *var, locus *where) mpz_set_ui (size, 0); } - gfc_assign_data_value_range (var->expr, values.vnode->expr, - offset, range); + t = gfc_assign_data_value_range (var->expr, values.vnode->expr, + offset, range); mpz_add (offset, offset, range); mpz_clear (range); + + if (t == FAILURE) + break; } /* Assign initial value to symbol. */ -- cgit v1.2.1 From 8ae2b3042b0458b6806a577d2f2086da40dd286a Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 5 May 2010 19:35:22 +0000 Subject: 2010-05-05 Daniel Franke * resolve.c (traverse_data_list): Rephrase error message for non-constant bounds in data-implied-do. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159080 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2c79863a718..9852af8eac1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11837,6 +11837,7 @@ traverse_data_list (gfc_data_variable *var, locus *where) gfc_try retval = SUCCESS; mpz_init (frame.value); + mpz_init (trip); start = gfc_copy_expr (var->iter.start); end = gfc_copy_expr (var->iter.end); @@ -11845,26 +11846,29 @@ traverse_data_list (gfc_data_variable *var, locus *where) if (gfc_simplify_expr (start, 1) == FAILURE || start->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator start at %L does not simplify", &start->where); + gfc_error ("start of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } if (gfc_simplify_expr (end, 1) == FAILURE || end->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator end at %L does not simplify", &end->where); + gfc_error ("end of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } if (gfc_simplify_expr (step, 1) == FAILURE || step->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator step at %L does not simplify", &step->where); + gfc_error ("step of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } - mpz_init_set (trip, end->value.integer); + mpz_set (trip, end->value.integer); mpz_sub (trip, trip, start->value.integer); mpz_add (trip, trip, step->value.integer); @@ -11880,7 +11884,6 @@ traverse_data_list (gfc_data_variable *var, locus *where) { if (traverse_data_var (var->list, where) == FAILURE) { - mpz_clear (trip); retval = FAILURE; goto cleanup; } @@ -11889,7 +11892,6 @@ traverse_data_list (gfc_data_variable *var, locus *where) if (gfc_simplify_expr (e, 1) == FAILURE) { gfc_free_expr (e); - mpz_clear (trip); retval = FAILURE; goto cleanup; } @@ -11899,9 +11901,9 @@ traverse_data_list (gfc_data_variable *var, locus *where) mpz_sub_ui (trip, trip, 1); } - mpz_clear (trip); cleanup: mpz_clear (frame.value); + mpz_clear (trip); gfc_free_expr (start); gfc_free_expr (end); -- cgit v1.2.1 From f0ea8570881182295b51f8f8e90a7e43b3792691 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 10 May 2010 12:54:25 +0000 Subject: 2010-05-10 Janus Weil PR fortran/44044 * match.c (gfc_match_select_type): Move error message to resolve_select_type. * resolve.c (resolve_select_type): Error message moved here from gfc_match_select_type. Correctly set type of temporary. 2010-05-10 Janus Weil PR fortran/44044 * gfortran.dg/class_7.f03: Modified. * gfortran.dg/select_type_1.f03: Modified. * gfortran.dg/select_type_12.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159217 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9852af8eac1..5afb08d516f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7078,8 +7078,21 @@ resolve_select_type (gfc_code *code) ns = code->ext.ns; gfc_resolve (ns); + /* Check for F03:C813. */ + if (code->expr1->ts.type != BT_CLASS + && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) + { + gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " + "at %L", &code->loc); + return; + } + if (code->expr2) - selector_type = code->expr2->ts.u.derived->components->ts.u.derived; + { + if (code->expr1->symtree->n.sym->attr.untyped) + code->expr1->symtree->n.sym->ts = code->expr2->ts; + selector_type = code->expr2->ts.u.derived->components->ts.u.derived; + } else selector_type = code->expr1->ts.u.derived->components->ts.u.derived; -- cgit v1.2.1 From c58db1960816e1e1e65ba6a15a068d8f2f073d58 Mon Sep 17 00:00:00 2001 From: dfranke Date: Tue, 11 May 2010 15:43:16 +0000 Subject: gcc/fortran/: 2010-05-11 Daniel Franke PR fortran/31820 * resolve.c (validate_case_label_expr): Removed FIXME. (resolve_select): Raise default warning on case labels out of range of the case expression. gcc/testsuite/: 2010-05-11 Daniel Franke PR fortran/31820 * gfortran.dg/select_5.f90: Updated. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159278 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5afb08d516f..da8d896cba5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6747,8 +6747,9 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) return FAILURE; } - /* Convert the case value kind to that of case expression kind, if needed. - FIXME: Should a warning be issued? */ + /* Convert the case value kind to that of case expression kind, + if needed */ + if (e->ts.kind != case_expr->ts.kind) gfc_convert_type_warn (e, &case_expr->ts, 2, 0); @@ -6834,6 +6835,31 @@ resolve_select (gfc_code *code) return; } + + /* Raise a warning if an INTEGER case value exceeds the range of + the case-expr. Later, all expressions will be promoted to the + largest kind of all case-labels. */ + + if (type == BT_INTEGER) + for (body = code->block; body; body = body->block) + for (cp = body->ext.case_list; cp; cp = cp->next) + { + if (cp->low + && gfc_check_integer_range (cp->low->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning ("Expression in CASE statement at %L is " + "not in the range of %s", &cp->low->where, + gfc_typename (&case_expr->ts)); + + if (cp->high + && cp->low != cp->high + && gfc_check_integer_range (cp->high->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning ("Expression in CASE statement at %L is " + "not in the range of %s", &cp->high->where, + gfc_typename (&case_expr->ts)); + } + /* PR 19168 has a long discussion concerning a mismatch of the kinds of the SELECT CASE expression and its CASE values. Walk the lists of case values, and if we find a mismatch, promote case_expr to @@ -6856,7 +6882,6 @@ resolve_select (gfc_code *code) && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) continue; - /* FIXME: Should a warning be issued? */ if (cp->low != NULL && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0); @@ -6907,8 +6932,8 @@ resolve_select (gfc_code *code) /* Deal with single value cases and case ranges. Errors are issued from the validation function. */ - if(validate_case_label_expr (cp->low, case_expr) != SUCCESS - || validate_case_label_expr (cp->high, case_expr) != SUCCESS) + if (validate_case_label_expr (cp->low, case_expr) != SUCCESS + || validate_case_label_expr (cp->high, case_expr) != SUCCESS) { t = FAILURE; break; @@ -6930,7 +6955,7 @@ resolve_select (gfc_code *code) value = cp->low->value.logical == 0 ? 2 : 1; if (value & seen_logical) { - gfc_error ("constant logical value in CASE statement " + gfc_error ("Constant logical value in CASE statement " "is repeated at %L", &cp->low->where); t = FAILURE; -- cgit v1.2.1 From 1e4299bb4266c9bd3cdbbe4ffdee917704f00fa6 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 May 2010 08:25:06 +0000 Subject: 2010-05-17 Janus Weil PR fortran/44044 * resolve.c (resolve_fl_var_and_proc): Move error messages here from ... (resolve_fl_variable_derived): ... this place. (resolve_symbol): Make sure function symbols (and their result variables) are not resolved twice. 2010-05-17 Janus Weil PR fortran/44044 * gfortran.dg/class_20.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159476 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 48 +++++++++++++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 21 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index da8d896cba5..d165bd66162 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9143,6 +9143,29 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } } + + /* Constraints on polymorphic variables. */ + if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) + { + /* F03:C502. */ + if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) + { + gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", + sym->ts.u.derived->components->ts.u.derived->name, + sym->name, &sym->declared_at); + return FAILURE; + } + + /* F03:C509. */ + /* Assume that use associated symbols were checked in the module ns. */ + if (!sym->attr.class_ok && !sym->attr.use_assoc) + { + gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " + "or pointer", sym->name, &sym->declared_at); + return FAILURE; + } + } + return SUCCESS; } @@ -9194,27 +9217,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) &sym->declared_at) == FAILURE) return FAILURE; - if (sym->ts.type == BT_CLASS) - { - /* C502. */ - if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) - { - gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->components->ts.u.derived->name, - sym->name, &sym->declared_at); - return FAILURE; - } - - /* C509. */ - /* Assume that use associated symbols were checked in the module ns. */ - if (!sym->attr.class_ok && !sym->attr.use_assoc) - { - gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " - "or pointer", sym->name, &sym->declared_at); - return FAILURE; - } - } - /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) && (!no_init_flag || sym->attr.intent == INTENT_OUT)) @@ -11130,6 +11132,10 @@ resolve_symbol (gfc_symbol *sym) gfc_namespace *ns; gfc_component *c; + /* Avoid double resolution of function result symbols. */ + if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns)) + return; + if (sym->attr.flavor == FL_UNKNOWN) { -- cgit v1.2.1 From 0826251092361171d72575cd36d4578e22cf9e9e Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 19 May 2010 13:07:25 +0000 Subject: gcc/fortran/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.h (gfc_has_default_initializer): New. * expr.c (gfc_has_default_initializer): New. * resolve.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-array.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-decl.c (generate_local_decl): Do not check the first component only to check for initializers, but use gfc_has_default_initializer() instead. gcc/testsuite/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.dg/warn_intent_out_not_set.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159562 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 25 +++++-------------------- 1 file changed, 5 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d165bd66162..e5a46fac615 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -703,21 +703,6 @@ resolve_entries (gfc_namespace *ns) } -static bool -has_default_initializer (gfc_symbol *der) -{ - gfc_component *c; - - gcc_assert (der->attr.flavor == FL_DERIVED); - for (c = der->components; c; c = c->next) - if ((c->ts.type != BT_DERIVED && c->initializer) - || (c->ts.type == BT_DERIVED - && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) - break; - - return c != NULL; -} - /* Resolve common variables. */ static void resolve_common_vars (gfc_symbol *sym, bool named_common) @@ -751,7 +736,7 @@ resolve_common_vars (gfc_symbol *sym, bool named_common) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "has an ultimate component that is " "allocatable", csym->name, &csym->declared_at); - if (has_default_initializer (csym->ts.u.derived)) + if (gfc_has_default_initializer (csym->ts.u.derived)) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "may not have default initializer", csym->name, &csym->declared_at); @@ -8056,7 +8041,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) and rhs is the same symbol as the lhs. */ if ((*rhsptr)->expr_type == EXPR_VARIABLE && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED - && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) + && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) *rhsptr = gfc_get_parentheses (*rhsptr); @@ -9204,13 +9189,13 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) or POINTER attribute, the object shall have the SAVE attribute." The check for initializers is performed with - has_default_initializer because gfc_default_initializer generates + gfc_has_default_initializer because gfc_default_initializer generates a hidden default for allocatable components. */ if (!(sym->value || no_init_flag) && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable - && has_default_initializer (sym->ts.u.derived) + && gfc_has_default_initializer (sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for " "module variable '%s' at %L, needed due to " "the default initialization", sym->name, @@ -12245,7 +12230,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) return FAILURE; } - if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived)) + if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) { gfc_error ("Derived type variable '%s' at %L with default " "initialization cannot be in EQUIVALENCE with a variable " -- cgit v1.2.1 From a96bd516338df9c61aa2692f140af6acc497eb88 Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 22 May 2010 10:21:32 +0000 Subject: 2010-05-22 Janus Weil PR fortran/44213 * resolve.c (ensure_not_abstract): Allow abstract types with non-abstract ancestors. 2010-05-22 Janus Weil PR fortran/44213 * gfortran.dg/abstract_type_7.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159695 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e5a46fac615..f08e1988816 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10541,7 +10541,10 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) This is not the most efficient way to do this, but it should be ok and is clearer than something sophisticated. */ - gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract); + gcc_assert (ancestor && !sub->attr.abstract); + + if (!ancestor->attr.abstract) + return SUCCESS; /* Walk bindings of this ancestor. */ if (ancestor->f2k_derived) -- cgit v1.2.1 From ebdf1a90331e831625837777390992ff585cc16c Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 22 May 2010 18:55:53 +0000 Subject: 2010-05-22 Janus Weil PR fortran/44212 * match.c (gfc_match_select_type): On error jump back out of the local namespace. * parse.c (parse_derived): Defer creation of vtab symbols to resolution stage, more precisely to ... * resolve.c (resolve_fl_derived): ... this place. 2010-05-22 Janus Weil PR fortran/44212 * gfortran.dg/class_22.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159745 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f08e1988816..1f4c236789a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10577,6 +10577,22 @@ resolve_fl_derived (gfc_symbol *sym) int i; super_type = gfc_get_derived_super_type (sym); + + if (sym->attr.is_class && sym->ts.u.derived == NULL) + { + /* Fix up incomplete CLASS symbols. */ + gfc_component *data; + gfc_component *vptr; + gfc_symbol *vtab; + data = gfc_find_component (sym, "$data", true, true); + vptr = gfc_find_component (sym, "$vptr", true, true); + if (vptr->ts.u.derived == NULL) + { + vtab = gfc_find_derived_vtab (data->ts.u.derived, false); + gcc_assert (vtab); + vptr->ts.u.derived = vtab->ts.u.derived; + } + } /* F2008, C432. */ if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) -- cgit v1.2.1 From d5156c99fe61ac2fe67f1c51f0fc7718d0b3d293 Mon Sep 17 00:00:00 2001 From: dfranke Date: Tue, 25 May 2010 18:10:01 +0000 Subject: gcc/fortran/: 2010-05-25 Daniel Franke PR fortran/30668 PR fortran/31346 PR fortran/34260 * resolve.c (resolve_global_procedure): Add check for global procedures with implicit interfaces and assumed-shape or optional dummy arguments. Verify that function return type, kind and string lengths match. gcc/testsuite/: 2010-05-25 Daniel Franke PR fortran/30668 PR fortran/31346 PR fortran/34260 * gfortran.dg/pr40999.f: Fix function type. * gfortran.dg/whole_file_5.f90: Likewise. * gfortran.dg/whole_file_6.f90: Likewise. * gfortran.dg/whole_file_16.f90: New. * gfortran.dg/whole_file_17.f90: New. * gfortran.dg/whole_file_18.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159838 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 63 ++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 57 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1f4c236789a..f2c24409cc8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1864,7 +1864,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_error ("The reference to function '%s' at %L either needs an " "explicit INTERFACE or the rank is incorrect", sym->name, where); - + /* Non-assumed length character functions. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER && gsym->ns->proc_name->ts.u.cl->length != NULL) @@ -1872,18 +1872,69 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_charlen *cl = sym->ts.u.cl; if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) { - gfc_error ("Nonconstant character-length function '%s' at %L " + gfc_error ("Nonconstant character-length function '%s' at %L " "must have an explicit interface", sym->name, &sym->declared_at); } } + /* Differences in constant character lengths. */ + if (sym->attr.function && sym->ts.type == BT_CHARACTER) + { + long int l1 = 0, l2 = 0; + gfc_charlen *cl1 = sym->ts.u.cl; + gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl; + + if (cl1 != NULL + && cl1->length != NULL + && cl1->length->expr_type == EXPR_CONSTANT) + l1 = mpz_get_si (cl1->length->value.integer); + + if (cl2 != NULL + && cl2->length != NULL + && cl2->length->expr_type == EXPR_CONSTANT) + l2 = mpz_get_si (cl2->length->value.integer); + + if (l1 && l2 && l1 != l2) + gfc_error ("Character length mismatch in return type of " + "function '%s' at %L (%ld/%ld)", sym->name, + &sym->declared_at, l1, l2); + } + + /* Type mismatch of function return type and expected type. */ + if (sym->attr.function + && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts)) + gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + sym->name, &sym->declared_at, gfc_typename (&sym->ts), + gfc_typename (&gsym->ns->proc_name->ts)); + + /* Assumed shape arrays as dummy arguments. */ + if (gsym->ns->proc_name->formal) + { + gfc_formal_arglist *arg = gsym->ns->proc_name->formal; + for ( ; arg; arg = arg->next) + if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Procedure '%s' at %L with assumed-shape dummy " + "'%s' argument must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + else if (arg->sym && arg->sym->attr.optional) + { + gfc_error ("Procedure '%s' at %L with optional dummy argument " + "'%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + } + if (gfc_option.flag_whole_file == 1 - || ((gfc_option.warn_std & GFC_STD_LEGACY) - && - !(gfc_option.warn_std & GFC_STD_GNU))) + || ((gfc_option.warn_std & GFC_STD_LEGACY) + && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); gfc_procedure_use (gsym->ns->proc_name, actual, where); -- cgit v1.2.1 From 7e33d332035bed444fb7a00d8f40ed50bdfc2739 Mon Sep 17 00:00:00 2001 From: pault Date: Wed, 26 May 2010 05:11:04 +0000 Subject: 2010-05-26 Paul Thomas PR fortran/40011 * resolve.c (resolve_global_procedure): Resolve the gsymbol's namespace before trying to reorder the gsymbols. 2010-05-26 Paul Thomas PR fortran/40011 * gfortran.dg/whole_file_19.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159852 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f2c24409cc8..1538ea0c9ab 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1824,20 +1824,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && not_in_recursive (sym, gsym->ns) && not_entry_self_reference (sym, gsym->ns)) { - /* Make sure that translation for the gsymbol occurs before - the procedure currently being resolved. */ - ns = gsym->ns->resolved ? NULL : gfc_global_ns_list; - for (; ns && ns != gsym->ns; ns = ns->sibling) - { - if (ns->sibling == gsym->ns) - { - ns->sibling = gsym->ns->sibling; - gsym->ns->sibling = gfc_global_ns_list; - gfc_global_ns_list = gsym->ns; - break; - } - } - + /* Resolve the gsymbol namespace if needed. */ if (!gsym->ns->resolved) { gfc_dt_list *old_dt_list; @@ -1857,6 +1844,20 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_derived_types = old_dt_list; } + /* Make sure that translation for the gsymbol occurs before + the procedure currently being resolved. */ + ns = gfc_global_ns_list; + for (; ns && ns != gsym->ns; ns = ns->sibling) + { + if (ns->sibling == gsym->ns) + { + ns->sibling = gsym->ns->sibling; + gsym->ns->sibling = gfc_global_ns_list; + gfc_global_ns_list = gsym->ns; + break; + } + } + if (gsym->ns->proc_name->attr.function && gsym->ns->proc_name->as && gsym->ns->proc_name->as->rank -- cgit v1.2.1 From 50b4b37ba4128b5e02d6b8af5f872770063c1d2b Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 30 May 2010 21:56:11 +0000 Subject: 2010-05-30 Janus Weil * gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the $data component of a class container. * gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA. * gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol, gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto. * gcc/fortran/interface.c (matching_typebound_op): Ditto. * gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto. * gcc/fortran/parse.c (parse_derived): Ditto. * gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr, gfc_expr_attr): Ditto. * gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec, resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type, resolve_fl_var_and_proc, resolve_typebound_procedure, resolve_fl_derived): Ditto. * gcc/fortran/symbol.c (gfc_type_compatible): Restructured. * gcc/fortran/trans-array.c (structure_alloc_comps): Use macro CLASS_DATA. * gcc/fortran/trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Ditto. * gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160060 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 75 ++++++++++++++++++++++++--------------------------- 1 file changed, 35 insertions(+), 40 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1538ea0c9ab..48bb6187c17 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -905,8 +905,8 @@ resolve_structure_cons (gfc_expr *expr) && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || (comp->ts.type == BT_CLASS - && (comp->ts.u.derived->components->attr.pointer - || comp->ts.u.derived->components->attr.allocatable)))) + && (CLASS_DATA (comp)->attr.pointer + || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; gfc_error ("The NULL in the derived type constructor at %L is " @@ -4131,7 +4131,7 @@ find_array_spec (gfc_expr *e) gfc_ref *ref; if (e->symtree->n.sym->ts.type == BT_CLASS) - as = e->symtree->n.sym->ts.u.derived->components->as; + as = CLASS_DATA (e->symtree->n.sym)->as; else as = e->symtree->n.sym->as; derived = NULL; @@ -6004,8 +6004,8 @@ resolve_deallocate_expr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { - allocatable = sym->ts.u.derived->components->attr.allocatable; - pointer = sym->ts.u.derived->components->attr.pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + pointer = CLASS_DATA (sym)->attr.pointer; } else { @@ -6028,8 +6028,8 @@ resolve_deallocate_expr (gfc_expr *e) c = ref->u.c.component; if (c->ts.type == BT_CLASS) { - allocatable = c->ts.u.derived->components->attr.allocatable; - pointer = c->ts.u.derived->components->attr.pointer; + allocatable = CLASS_DATA (c)->attr.allocatable; + pointer = CLASS_DATA (c)->attr.pointer; } else { @@ -6224,11 +6224,11 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { if (sym->ts.type == BT_CLASS) { - allocatable = sym->ts.u.derived->components->attr.allocatable; - pointer = sym->ts.u.derived->components->attr.pointer; - dimension = sym->ts.u.derived->components->attr.dimension; - codimension = sym->ts.u.derived->components->attr.codimension; - is_abstract = sym->ts.u.derived->components->attr.abstract; + allocatable = CLASS_DATA (sym)->attr.allocatable; + pointer = CLASS_DATA (sym)->attr.pointer; + dimension = CLASS_DATA (sym)->attr.dimension; + codimension = CLASS_DATA (sym)->attr.codimension; + is_abstract = CLASS_DATA (sym)->attr.abstract; } else { @@ -6262,11 +6262,11 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) c = ref->u.c.component; if (c->ts.type == BT_CLASS) { - allocatable = c->ts.u.derived->components->attr.allocatable; - pointer = c->ts.u.derived->components->attr.pointer; - dimension = c->ts.u.derived->components->attr.dimension; - codimension = c->ts.u.derived->components->attr.codimension; - is_abstract = c->ts.u.derived->components->attr.abstract; + allocatable = CLASS_DATA (c)->attr.allocatable; + pointer = CLASS_DATA (c)->attr.pointer; + dimension = CLASS_DATA (c)->attr.dimension; + codimension = CLASS_DATA (c)->attr.codimension; + is_abstract = CLASS_DATA (c)->attr.abstract; } else { @@ -6349,7 +6349,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } else if (e->ts.type == BT_CLASS && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts))) + && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) || (code->ext.alloc.ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) { @@ -7153,10 +7153,10 @@ resolve_select_type (gfc_code *code) { if (code->expr1->symtree->n.sym->attr.untyped) code->expr1->symtree->n.sym->ts = code->expr2->ts; - selector_type = code->expr2->ts.u.derived->components->ts.u.derived; + selector_type = CLASS_DATA (code->expr2)->ts.u.derived; } else - selector_type = code->expr1->ts.u.derived->components->ts.u.derived; + selector_type = CLASS_DATA (code->expr1)->ts.u.derived; /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) @@ -9185,11 +9185,11 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) { /* F03:C502. */ - if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) + if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->components->ts.u.derived->name, - sym->name, &sym->declared_at); + CLASS_DATA (sym)->ts.u.derived->name, sym->name, + &sym->declared_at); return FAILURE; } @@ -10424,7 +10424,7 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - if (me_arg->ts.u.derived->components->ts.u.derived + if (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" @@ -10434,20 +10434,19 @@ resolve_typebound_procedure (gfc_symtree* stree) } gcc_assert (me_arg->ts.type == BT_CLASS); - if (me_arg->ts.u.derived->components->as - && me_arg->ts.u.derived->components->as->rank > 0) + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) { gfc_error ("Passed-object dummy argument of '%s' at %L must be" " scalar", proc->name, &where); goto error; } - if (me_arg->ts.u.derived->components->attr.allocatable) + if (CLASS_DATA (me_arg)->attr.allocatable) { gfc_error ("Passed-object dummy argument of '%s' at %L must not" " be ALLOCATABLE", proc->name, &where); goto error; } - if (me_arg->ts.u.derived->components->attr.class_pointer) + if (CLASS_DATA (me_arg)->attr.class_pointer) { gfc_error ("Passed-object dummy argument of '%s' at %L must not" " be POINTER", proc->name, &where); @@ -10633,14 +10632,11 @@ resolve_fl_derived (gfc_symbol *sym) if (sym->attr.is_class && sym->ts.u.derived == NULL) { /* Fix up incomplete CLASS symbols. */ - gfc_component *data; - gfc_component *vptr; - gfc_symbol *vtab; - data = gfc_find_component (sym, "$data", true, true); - vptr = gfc_find_component (sym, "$vptr", true, true); + gfc_component *data = gfc_find_component (sym, "$data", true, true); + gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true); if (vptr->ts.u.derived == NULL) { - vtab = gfc_find_derived_vtab (data->ts.u.derived, false); + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -10834,7 +10830,7 @@ resolve_fl_derived (gfc_symbol *sym) if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) || (me_arg->ts.type == BT_CLASS - && me_arg->ts.u.derived->components->ts.u.derived != sym)) + && CLASS_DATA (me_arg)->ts.u.derived != sym)) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived type '%s'", me_arg->name, c->name, @@ -10947,9 +10943,9 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer - && c->ts.u.derived->components->ts.u.derived->components == NULL - && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp) + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer + && CLASS_DATA (c)->ts.u.derived->components == NULL + && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " "that has not been declared", c->name, sym->name, @@ -10959,8 +10955,7 @@ resolve_fl_derived (gfc_symbol *sym) /* C437. */ if (c->ts.type == BT_CLASS - && !(c->ts.u.derived->components->attr.pointer - || c->ts.u.derived->components->attr.allocatable)) + && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); -- cgit v1.2.1 From 8913205507893383ed27be9d58b7a8c0f5952261 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 6 Jun 2010 02:04:04 +0000 Subject: 2010-06-05 Paul Thomas Janus Weil PR fortran/43945 * resolve.c (get_declared_from_expr): Move to before resolve_typebound_generic_call. Make new_ref and class_ref ignorable if set to NULL. (resolve_typebound_generic_call): Once we have resolved the generic call, check that the specific instance is that which is bound to the declared type. (resolve_typebound_function,resolve_typebound_subroutine): Avoid freeing 'class_ref->next' twice. 2010-06-05 Paul Thomas PR fortran/43945 * gfortran.dg/generic_23.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160335 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 98 +++++++++++++++++++++++++++++---------------------- 1 file changed, 56 insertions(+), 42 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 48bb6187c17..7e5a4f95773 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5160,6 +5160,43 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, } +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + if (class_ref) + *class_ref = NULL; + if (new_ref) + *new_ref = gfc_copy_ref (e->ref); + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if (ref->u.c.component->ts.type == BT_CLASS + || ref->u.c.component->ts.type == BT_DERIVED) + { + declared = ref->u.c.component->ts.u.derived; + if (class_ref) + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ @@ -5169,6 +5206,8 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; + gfc_symtree *st; + gfc_symbol *derived; gcc_assert (e->expr_type == EXPR_COMPCALL); genname = e->value.compcall.name; @@ -5236,6 +5275,19 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) return FAILURE; success: + /* Make sure that we have the right specific instance for the name. */ + genname = e->value.compcall.tbp->u.specific->name; + + /* Is the symtree name a "unique name". */ + if (*genname == '@') + genname = e->value.compcall.tbp->u.specific->n.sym->name; + + derived = get_declared_from_expr (NULL, NULL, e); + + st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); + if (st) + e->value.compcall.tbp = st->n.tb; + return SUCCESS; } @@ -5343,38 +5395,6 @@ resolve_compcall (gfc_expr* e, const char **name) } -/* Get the ultimate declared type from an expression. In addition, - return the last class/derived type reference and the copy of the - reference list. */ -static gfc_symbol* -get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e) -{ - gfc_symbol *declared; - gfc_ref *ref; - - declared = NULL; - *class_ref = NULL; - *new_ref = gfc_copy_ref (e->ref); - for (ref = *new_ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - continue; - - if (ref->u.c.component->ts.type == BT_CLASS - || ref->u.c.component->ts.type == BT_DERIVED) - { - declared = ref->u.c.component->ts.u.derived; - *class_ref = ref; - } - } - - if (declared == NULL) - declared = e->symtree->n.sym->ts.u.derived; - - return declared; -} - /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ @@ -5423,11 +5443,8 @@ resolve_typebound_function (gfc_expr* e) e->value.function.esym = NULL; e->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - e->ref = new_ref; - } + if (new_ref) + e->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); @@ -5496,11 +5513,8 @@ resolve_typebound_subroutine (gfc_code *code) code->expr1->value.function.esym = NULL; code->expr1->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - code->expr1->ref = new_ref; - } + if (new_ref) + code->expr1->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); -- cgit v1.2.1 From 4e1f7cdd604ce719e2906cc612bca05c52a5f08a Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 8 Jun 2010 06:37:32 +0000 Subject: 2010-06-07 Tobias Burnus PR fortran/44446 * symbol.c (check_conflict): Move protected--external/procedure check ... * resolve.c (resolve_select_type): ... to the resolution stage. 2010-06-07 Tobias Burnus PR fortran/44446 * gfortran.dg/proc_ptr_27.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160424 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7e5a4f95773..e4c739430a8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11311,6 +11311,19 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->attr.is_protected && !sym->attr.proc_pointer + && (sym->attr.procedure || sym->attr.external)) + { + if (sym->attr.external) + gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " + "at %L", &sym->declared_at); + else + gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " + "at %L", &sym->declared_at); + + return; + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; -- cgit v1.2.1 From 2e67d2c99941dcf92d2c09581080f7d46ee40d56 Mon Sep 17 00:00:00 2001 From: ktietz Date: Wed, 9 Jun 2010 11:39:33 +0000 Subject: 2010-06-09 Kai Tietz * fortran/resolve.c (resolve_deallocate_expr): Avoid warning about possible use of iunitialized sym. (resolve_allocate_expr): Pre-initialize sym by NULL. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160464 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e4c739430a8..2ee82afbe5a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6065,6 +6065,7 @@ resolve_deallocate_expr (gfc_expr *e) bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); + return FAILURE; } if (check_intent_in && sym->attr.intent == INTENT_IN) @@ -6196,7 +6197,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; gfc_expr *init_e; -- cgit v1.2.1 From ae44f506b688aea6957f94da64403b98b33aa7c5 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 9 Jun 2010 14:14:08 +0000 Subject: 2010-06-09 Janus Weil PR fortran/44211 * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Resolve references. 2010-06-09 Janus Weil PR fortran/44211 * gfortran.dg/typebound_call_14.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160478 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2ee82afbe5a..8fabf4e69b7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5415,6 +5415,9 @@ resolve_typebound_function (gfc_expr* e) if (st == NULL) return resolve_compcall (e, NULL); + if (resolve_ref (e) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); @@ -5487,6 +5490,9 @@ resolve_typebound_subroutine (gfc_code *code) if (st == NULL) return resolve_typebound_call (code, NULL); + if (resolve_ref (code->expr1) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); -- cgit v1.2.1 From d18a512a42d8072efb8b9f2bb82ea97536b4cea3 Mon Sep 17 00:00:00 2001 From: domob Date: Thu, 10 Jun 2010 14:47:49 +0000 Subject: 2010-06-10 Daniel Kraft PR fortran/38936 * gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE. (struct gfc_symbol): New field `assoc'. (struct gfc_association_list): New struct. (struct gfc_code): New struct `block' in union, move `ns' there and add association list. (gfc_free_association_list): New method. (gfc_has_vector_subscript): Made public; * match.h (gfc_match_associate): New method. * parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE. * decl.c (gfc_match_end): Handle ST_END_ASSOCIATE. * interface.c (gfc_has_vector_subscript): Made public. (compare_actual_formal): Rename `has_vector_subscript' accordingly. * match.c (gfc_match_associate): New method. (gfc_match_select_type): Change reference to gfc_code's `ns' field. * primary.c (match_variable): Don't allow names associated to expr here. * parse.c (decode_statement): Try matching ASSOCIATE statement. (case_exec_markers, case_end): Add ASSOCIATE statement. (gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE. (parse_associate): New method. (parse_executable): Handle ST_ASSOCIATE. (parse_block_construct): Change reference to gfc_code's `ns' field. * resolve.c (resolve_select_type): Ditto. (resolve_code): Ditto. (resolve_block_construct): Ditto and add comment. (resolve_select_type): Set association list in generated BLOCK to NULL. (resolve_symbol): Resolve associate names. * st.c (gfc_free_statement): Change reference to gfc_code's `ns' field and free association list. (gfc_free_association_list): New method. * symbol.c (gfc_new_symbol): NULL new field `assoc'. * trans-stmt.c (gfc_trans_block_construct): Change reference to gfc_code's `ns' field. 2010-06-10 Daniel Kraft PR fortran/38936 * gfortran.dg/associate_1.f03: New test. * gfortran.dg/associate_2.f95: New test. * gfortran.dg/associate_3.f03: New test. * gfortran.dg/associate_4.f08: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160550 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8fabf4e69b7..5f920c9e3d3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7158,7 +7158,7 @@ resolve_select_type (gfc_code *code) gfc_namespace *ns; int error = 0; - ns = code->ext.ns; + ns = code->ext.block.ns; gfc_resolve (ns); /* Check for F03:C813. */ @@ -7245,6 +7245,7 @@ resolve_select_type (gfc_code *code) else ns->code->next = new_st; code->op = EXEC_BLOCK; + code->ext.block.assoc = NULL; code->expr1 = code->expr2 = NULL; code->block = NULL; @@ -7988,10 +7989,11 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static void resolve_block_construct (gfc_code* code) { - /* Eventually, we may want to do some checks here or handle special stuff. - But so far the only thing we can do is resolving the local namespace. */ + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during gfc_resolve_symbol. */ - gfc_resolve (code->ext.ns); + /* Resolve the BLOCK's namespace. */ + gfc_resolve (code->ext.block.ns); } @@ -8312,7 +8314,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: - gfc_current_ns = code->ext.ns; + gfc_current_ns = code->ext.block.ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = ns; break; @@ -8476,7 +8478,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_BLOCK: - gfc_resolve (code->ext.ns); + gfc_resolve (code->ext.block.ns); break; case EXEC_DO: @@ -11341,7 +11343,6 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal representation. This needs to be done before assigning a default type to avoid spurious warnings. */ @@ -11349,6 +11350,18 @@ resolve_symbol (gfc_symbol *sym) && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; + /* For associate names, resolve corresponding expression and make sure + they get their type-spec set this way. */ + if (sym->assoc) + { + gcc_assert (sym->attr.flavor == FL_VARIABLE); + if (gfc_resolve_expr (sym->assoc->target) != SUCCESS) + return; + + sym->ts = sym->assoc->target->ts; + gcc_assert (sym->ts.type != BT_UNKNOWN); + } + /* Assign default type to symbols that need one and don't have one. */ if (sym->ts.type == BT_UNKNOWN) { -- cgit v1.2.1 From 4c0165a9e7394ed309aaaa8ad19de713f3b4107f Mon Sep 17 00:00:00 2001 From: kargl Date: Fri, 11 Jun 2010 00:06:30 +0000 Subject: 2010-06-10 Steven G. Kargl * resolve.c (resolve_operator): Fix whitespace. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160584 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5f920c9e3d3..226c2f9197b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3615,11 +3615,11 @@ resolve_operator (gfc_expr *e) e->rank = op1->rank; if (e->shape == NULL) { - t = compare_shapes(op1, op2); + t = compare_shapes (op1, op2); if (t == FAILURE) e->shape = NULL; else - e->shape = gfc_copy_shape (op1->shape, op1->rank); + e->shape = gfc_copy_shape (op1->shape, op1->rank); } } else -- cgit v1.2.1 From ad0fe61dc390856017085222ba1e751ac1a45c97 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 11 Jun 2010 01:42:38 +0000 Subject: 2010-06-10 Janus Weil PR fortran/44207 * resolve.c (conformable_arrays): Handle allocatable components. 2010-06-10 Janus Weil PR fortran/44207 * gfortran.dg/allocate_alloc_opt_7.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160589 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 226c2f9197b..4b4c50559c3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6146,8 +6146,11 @@ gfc_expr_to_initialize (gfc_expr *e) static gfc_try conformable_arrays (gfc_expr *e1, gfc_expr *e2) { + gfc_ref *tail; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* First compare rank. */ - if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + if (tail && e1->rank != tail->u.ar.as->rank) { gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", @@ -6164,15 +6167,15 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) for (i = 0; i < e1->rank; i++) { - if (e2->ref->u.ar.end[i]) + if (tail->u.ar.end[i]) { - mpz_set (s, e2->ref->u.ar.end[i]->value.integer); - mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.end[i]->value.integer); + mpz_sub (s, s, tail->u.ar.start[i]->value.integer); mpz_add_ui (s, s, 1); } else { - mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) -- cgit v1.2.1 From ab0a1ed67c21194d59fb8b6c8791953a93bab581 Mon Sep 17 00:00:00 2001 From: dfranke Date: Sat, 12 Jun 2010 13:43:48 +0000 Subject: gcc/fortran/: 2010-06-12 Daniel Franke * resolve.c (resolve_global_procedure): Improved checking if an explicit interface is required. gcc/testsuite/: 2010-06-12 Daniel Franke * gfortran.dg/whole_file_20.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160663 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 117 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 88 insertions(+), 29 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4b4c50559c3..d5fa3708d4e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1858,29 +1858,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - if (gsym->ns->proc_name->attr.function - && gsym->ns->proc_name->as - && gsym->ns->proc_name->as->rank - && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); - - /* Non-assumed length character functions. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); - } - } - /* Differences in constant character lengths. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER) { @@ -1911,26 +1888,108 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&gsym->ns->proc_name->ts)); - /* Assumed shape arrays as dummy arguments. */ if (gsym->ns->proc_name->formal) { gfc_formal_arglist *arg = gsym->ns->proc_name->formal; for ( ; arg; arg = arg->next) - if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_SHAPE) + if (!arg->sym) + continue; + /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ + else if (arg->sym->attr.allocatable + || arg->sym->attr.asynchronous + || arg->sym->attr.optional + || arg->sym->attr.pointer + || arg->sym->attr.target + || arg->sym->attr.value + || arg->sym->attr.volatile_) + { + gfc_error ("Dummy argument '%s' of procedure '%s' at %L " + "has an attribute that requires an explicit " + "interface for this procedure", arg->sym->name, + sym->name, &sym->declared_at); + break; + } + /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_SHAPE) { gfc_error ("Procedure '%s' at %L with assumed-shape dummy " - "'%s' argument must have an explicit interface", + "argument '%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } - else if (arg->sym && arg->sym->attr.optional) + /* F2008, 12.4.2.2 (2c) */ + else if (arg->sym->attr.codimension) { - gfc_error ("Procedure '%s' at %L with optional dummy argument " + gfc_error ("Procedure '%s' at %L with coarray dummy argument " "'%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } + /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ + else if (false) /* TODO: is a parametrized derived type */ + { + gfc_error ("Procedure '%s' at %L with parametrized derived " + "type argument '%s' must have an explicit " + "interface", sym->name, &sym->declared_at, + arg->sym->name); + break; + } + /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ + else if (arg->sym->ts.type == BT_CLASS) + { + gfc_error ("Procedure '%s' at %L with polymorphic dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + } + + if (gsym->ns->proc_name->attr.function) + { + /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ + if (gsym->ns->proc_name->as + && gsym->ns->proc_name->as->rank + && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ + if (gsym->ns->proc_name->result->attr.pointer + || gsym->ns->proc_name->result->attr.allocatable) + gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " + "result must have an explicit interface", sym->name, + where); + + /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ + if (sym->ts.type == BT_CHARACTER + && gsym->ns->proc_name->ts.u.cl->length != NULL) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Nonconstant character-length function '%s' at %L " + "must have an explicit interface", sym->name, + &sym->declared_at); + } + } + } + + /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ + if (gsym->ns->proc_name->attr.elemental) + { + gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " + "interface", sym->name, &sym->declared_at); + } + + /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ + if (gsym->ns->proc_name->attr.is_bind_c) + { + gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " + "an explicit interface", sym->name, &sym->declared_at); } if (gfc_option.flag_whole_file == 1 -- cgit v1.2.1 From de6229046ca7a9d04c27f1d5427258d272f8bdbf Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 15 Jun 2010 18:33:58 +0000 Subject: 2010-06-15 Janus Weil PR fortran/43388 * gfortran.h (gfc_expr): Add new member 'mold'. * match.c (gfc_match_allocate): Implement the MOLD tag. * resolve.c (resolve_allocate_expr): Ditto. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-06-15 Janus Weil PR fortran/43388 * gfortran.dg/allocate_alloc_opt_8.f90: New. * gfortran.dg/allocate_alloc_opt_9.f90: New. * gfortran.dg/allocate_alloc_opt_10.f90: New. * gfortran.dg/class_allocate_2.f03: Modified an error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160801 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 43 +++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d5fa3708d4e..7e6b75aebe1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6268,7 +6268,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6401,11 +6400,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or SOURCE=", sym->name, &e->where); + "type-spec or source-expr", sym->name, &e->where); goto failure; } @@ -6416,25 +6418,26 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (!code->expr3) + if (!code->expr3 || code->expr3->mold) { /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + gfc_expr *init_e = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = e->ts; + + if (ts.type == BT_DERIVED) + init_e = gfc_default_initializer (&ts); + /* FIXME: Use default init of dynamic type (cf. PR 44541). */ + else if (e->ts.type == BT_CLASS) + init_e = gfc_default_initializer (&ts.u.derived->components->ts); + + if (init_e) { gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; -- cgit v1.2.1 From d17bd57e7deb645f6208bcb754c632047d1e08d1 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 17 Jun 2010 22:15:30 +0000 Subject: 2010-06-17 Janus Weil PR fortran/44558 * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Return directly in case of an error. 2010-06-17 Janus Weil PR fortran/44558 * gfortran.dg/typebound_call_15.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160948 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7e6b75aebe1..52920f4e6cc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5498,7 +5498,8 @@ resolve_typebound_function (gfc_expr* e) /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ - resolve_compcall (e, &name); + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; ts = e->ts; /* Then convert the expression to a procedure pointer component call. */ @@ -5571,7 +5572,8 @@ resolve_typebound_subroutine (gfc_code *code) if (code->expr1->value.compcall.tbp->is_generic) genname = code->expr1->value.compcall.name; - resolve_typebound_call (code, &name); + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; ts = code->expr1->ts; /* Then convert the expression to a procedure pointer component call. */ -- cgit v1.2.1 From 7e6fae0b710882e2274b65770915ff82fc19678a Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 18 Jun 2010 22:23:40 +0000 Subject: 2010-06-18 Tobias Burnus PR fortran/44556 * resolve.c (resolve_allocate_deallocate): Properly check part-refs in stat=/errmsg= for invalid use. 2010-06-18 Tobias Burnus PR fortran/44556 * gfortran.dg/allocate_alloc_opt_11.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161011 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 46 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 52920f4e6cc..0951498e2db 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6591,8 +6591,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) - gfc_error ("Stat-variable at %L shall not be %sd within " - "the same %s statement", &stat->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Stat-variable at %L shall not be %sd within " + "the same %s statement", &stat->where, fcn, fcn); + break; + } + } } /* Check the errmsg variable. */ @@ -6620,8 +6641,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) - gfc_error ("Errmsg-variable at %L shall not be %sd within " - "the same %s statement", &errmsg->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Errmsg-variable at %L shall not be %sd within " + "the same %s statement", &errmsg->where, fcn, fcn); + break; + } + } } /* Check that an allocate-object appears only once in the statement. -- cgit v1.2.1 From d839f2a021f09bbbd890032de84e6b76ff8a17a8 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 20 Jun 2010 00:05:35 +0000 Subject: 2010-06-19 Janus Weil PR fortran/44584 * resolve.c (resolve_fl_derived): Reverse ordering of conditions to avoid ICE. 2010-06-19 Janus Weil PR fortran/44584 * gfortran.dg/typebound_proc_15.f03: Modified. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161041 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0951498e2db..2f05b23b02f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10892,7 +10892,7 @@ resolve_fl_derived (gfc_symbol *sym) c->ts.u.cl = cl; } } - else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype) + else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') { gfc_error ("Interface '%s' of procedure pointer component " "'%s' at %L must be explicit", c->ts.interface->name, -- cgit v1.2.1 From b3c3927c05d8ad190b76c56ae6020e1650b85a97 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 21 Jun 2010 14:15:56 +0000 Subject: 2010-06-20 Tobias Burnus PR fortran/40632 * interface.c (compare_parameter): Add gfc_is_simply_contiguous checks. * symbol.c (gfc_add_contiguous): New function. (gfc_copy_attr, check_conflict): Handle contiguous attribute. * decl.c (match_attr_spec): Ditto. (gfc_match_contiguous): New function. * resolve.c (resolve_fl_derived, resolve_symbol): Handle contiguous. * gfortran.h (symbol_attribute): Add contiguous. (gfc_is_simply_contiguous): Add prototype. (gfc_add_contiguous): Add prototype. * match.h (gfc_match_contiguous): Add prototype. * parse.c (decode_specification_statement, decode_statement): Handle contiguous attribute. * expr.c (gfc_is_simply_contiguous): New function. * dump-parse-tree.c (show_attr): Handle contiguous. * module.c (ab_attribute, attr_bits, mio_symbol_attribute): Ditto. * trans-expr.c (gfc_add_interface_mapping): Copy attr.contiguous. * trans-array.c (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter): Handle contiguous arrays. * trans-types.c (gfc_build_array_type, gfc_build_array_type, gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): Ditto. * trans.h (gfc_array_kind): Ditto. * trans-decl.c (gfc_get_symbol_decl): Ditto. 2010-06-20 Tobias Burnus PR fortran/40632 * gfortran.dg/contiguous_1.f90: New. * gfortran.dg/contiguous_2.f90: New. * gfortran.dg/contiguous_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161079 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2f05b23b02f..20def447767 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10826,6 +10826,14 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) + { + gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure && !sym->attr.vtype) @@ -11397,6 +11405,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.pure = ifc->attr.pure; sym->attr.elemental = ifc->attr.elemental; sym->attr.dimension = ifc->attr.dimension; + sym->attr.contiguous = ifc->attr.contiguous; sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; @@ -11442,6 +11451,18 @@ resolve_symbol (gfc_symbol *sym) return; } + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.pointer))) + { + gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape array", sym->name, + &sym->declared_at); + return; + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; @@ -11500,6 +11521,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.dimension = sym->result->attr.dimension; sym->attr.pointer = sym->result->attr.pointer; sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; } } } -- cgit v1.2.1 From c420ccbb9d47c2ad0cf2a50a5ec9daa4e7c232f7 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 22 Jun 2010 17:07:06 +0000 Subject: 2010-06-22 Janus Weil PR fortran/44616 * resolve.c (resolve_fl_derived): Avoid checking for abstract on class containers. 2010-06-22 Janus Weil PR fortran/44616 * gfortran.dg/abstract_type_8.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161208 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 20def447767..96b3e8daab1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11144,6 +11144,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract + && !sym->attr.is_class && ensure_not_abstract (sym, super_type) == FAILURE) return FAILURE; -- cgit v1.2.1 From d6df670a714ffc7f42765e24d77a4d29b310eff6 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 29 Jun 2010 21:40:38 +0000 Subject: 2010-06-29 Janus Weil PR fortran/44718 * resolve.c (is_external_proc): Prevent procedure pointers from being regarded as external procedures. 2010-06-29 Janus Weil PR fortran/44718 * gfortran.dg/proc_ptr_28.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161569 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 96b3e8daab1..4e11fc6c311 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2259,6 +2259,7 @@ is_external_proc (gfc_symbol *sym) && !(sym->attr.intrinsic || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer && !sym->attr.use_assoc && sym->name) return true; -- cgit v1.2.1 From 58b069a099182c5367587d098eda613ee3947fec Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Jul 2010 20:56:07 +0000 Subject: 2010-07-06 Tobias Burnus PR fortran/44742 * array.c (gfc_expand_constructor): Add optional diagnostic. * gfortran.h (gfc_expand_constructor): Update prototype. * expr.c (gfc_simplify_expr, check_init_expr, gfc_reduce_init_expr): Update gfc_expand_constructor call. * resolve.c (gfc_resolve_expr): Ditto. 2010-07-06 Tobias Burnus PR fortran/44742 * gfortran.dg/parameter_array_init_6.f90: New. * gfortran.dg/initialization_20.f90: Update dg-error. * gfortran.dg/initialization_24.f90: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161888 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4e11fc6c311..a8ed5440655 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5776,7 +5776,7 @@ gfc_resolve_expr (gfc_expr *e) { expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); } /* This provides the opportunity for the length of constructors with @@ -5786,7 +5786,7 @@ gfc_resolve_expr (gfc_expr *e) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER here rather then add a duplicate test for it above. */ - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } -- cgit v1.2.1 From e20c5d834d5edde630d46ea1e1bc5cb6f673f3bd Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 10 Jul 2010 14:57:25 +0000 Subject: 2010-07-10 Paul Thomas PR fortran/44773 * trans-expr.c (arrayfunc_assign_needs_temporary): No temporary if the lhs has never been host associated, as well as not being use associated, a pointer or a target. * resolve.c (resolve_variable): Mark variables that are host associated. * gfortran.h: Add the host_assoc bit to the symbol_attribute structure. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162038 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a8ed5440655..98d1e079e50 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4772,6 +4772,15 @@ resolve_variable (gfc_expr *e) sym->entry_id = current_entry_id + 1; } + /* If a symbol has been host_associated mark it. This is used latter, + to identify if aliasing is possible via host association. */ + if (sym->attr.flavor == FL_VARIABLE + && gfc_current_ns->parent + && (gfc_current_ns->parent == sym->ns + || (gfc_current_ns->parent->parent + && gfc_current_ns->parent->parent == sym->ns))) + sym->attr.host_assoc = 1; + resolve_procedure: if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) t = FAILURE; -- cgit v1.2.1 From a33fbb6f8853e5ec06f3ec241af9f5e91bd4e1c3 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 11 Jul 2010 07:55:11 +0000 Subject: 2010-07-11 Janus Weil PR fortran/44689 * decl.c (build_sym,attr_decl1): Only build the class container if the symbol has sufficient attributes. * expr.c (gfc_check_pointer_assign): Use class_pointer instead of pointer attribute for classes. * match.c (gfc_match_allocate,gfc_match_deallocate): Ditto. * module.c (MOD_VERSION): Bump. (enum ab_attribute,attr_bits): Add AB_CLASS_POINTER. (mio_symbol_attribute): Handle class_pointer attribute. * parse.c (parse_derived): Use class_pointer instead of pointer attribute for classes. * primary.c (gfc_variable_attr,gfc_expr_attr): Ditto. * resolve.c (resolve_structure_cons,resolve_deallocate_expr, resolve_allocate_expr,resolve_fl_derived): Ditto. (resolve_fl_var_and_proc): Check for class_ok attribute. 2010-07-11 Janus Weil PR fortran/44689 * gfortran.dg/class_24.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162052 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 98d1e079e50..d5c422ac35e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -905,7 +905,7 @@ resolve_structure_cons (gfc_expr *expr) && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || (comp->ts.type == BT_CLASS - && (CLASS_DATA (comp)->attr.pointer + && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; @@ -6096,7 +6096,7 @@ resolve_deallocate_expr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; } else { @@ -6120,7 +6120,7 @@ resolve_deallocate_expr (gfc_expr *e) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; } else { @@ -6319,7 +6319,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; is_abstract = CLASS_DATA (sym)->attr.abstract; @@ -6357,7 +6357,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; dimension = CLASS_DATA (c)->attr.dimension; codimension = CLASS_DATA (c)->attr.codimension; is_abstract = CLASS_DATA (c)->attr.abstract; @@ -9327,7 +9327,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) { /* F03:C502. */ - if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) + if (sym->attr.class_ok + && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", CLASS_DATA (sym)->ts.u.derived->name, sym->name, @@ -11093,7 +11094,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) { @@ -11105,7 +11106,8 @@ resolve_fl_derived (gfc_symbol *sym) /* C437. */ if (c->ts.type == BT_CLASS - && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable)) + && !(CLASS_DATA (c)->attr.class_pointer + || CLASS_DATA (c)->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); -- cgit v1.2.1 From 417c9c5c12f60741c2984609d91f0c45cb302489 Mon Sep 17 00:00:00 2001 From: mikael Date: Mon, 12 Jul 2010 14:31:00 +0000 Subject: 2010-07-12 Mikael Morin * expr.c (gfc_get_int_expr): Don't initialize mpfr data twice. * resolve.c (build_default_init_expr): Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162081 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d5c422ac35e..f3ec19ccdbc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9139,7 +9139,7 @@ build_default_init_expr (gfc_symbol *sym) { case BT_INTEGER: if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_init_set_si (init_expr->value.integer, + mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else { @@ -9149,7 +9149,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_REAL: - mpfr_init (init_expr->value.real); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -9179,7 +9178,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_COMPLEX: - mpc_init2 (init_expr->value.complex, mpfr_get_default_prec()); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: -- cgit v1.2.1 From 09276310eee7ca1b0205abdb47fc612bec7ba51d Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 13 Jul 2010 06:57:17 +0000 Subject: 2010-07-13 Janus Weil PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.h (gfc_find_derived_vtab): Modified prototype. * class.c (gfc_build_class_symbol): Modified call to 'gfc_find_derived_vtab'. (add_proc_component): Removed, moved code into 'add_proc_comp'. (add_proc_comps): Renamed to 'add_proc_comp', removed treatment of generics. (add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'. Removed treatment of generics. (copy_vtab_proc_comps): Removed unnecessary argument 'resolved'. Call 'add_proc_comp' instead of duplicating code. (add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved' and 'declared'. (add_generic_specifics,add_generics_to_declared_vtab): Removed. (gfc_find_derived_vtab): Removed unnecessary argument 'resolved'. Removed treatment of generics. * iresolve.c (gfc_resolve_extends_type_of): Modified call to 'gfc_find_derived_vtab'. * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Removed treatment of generics. (resolve_select_type,resolve_fl_derived): Modified call to 'gfc_find_derived_vtab'. * trans-decl.c (gfc_get_symbol_decl): Ditto. * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): Ditto. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-07-13 Janus Weil PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.dg/dynamic_dispatch_1.f03: Fixed invalid test case. * gfortran.dg/dynamic_dispatch_2.f03: Ditto. * gfortran.dg/dynamic_dispatch_3.f03: Ditto. * gfortran.dh/typebound_call_16.f03: New. * gfortran.dg/typebound_generic_6.f03: New. * gfortran.dg/typebound_generic_7.f03: New. * gfortran.dg/typebound_generic_8.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162125 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 34 ++-------------------------------- 1 file changed, 2 insertions(+), 32 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f3ec19ccdbc..640a4d89fe1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5477,7 +5477,6 @@ resolve_typebound_function (gfc_expr* e) gfc_ref *class_ref; gfc_symtree *st; const char *name; - const char *genname; gfc_typespec ts; st = e->symtree; @@ -5501,11 +5500,6 @@ resolve_typebound_function (gfc_expr* e) c = gfc_find_component (declared, "$data", true, true); declared = c->ts.u.derived; - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (e->value.compcall.tbp->is_generic) - genname = e->value.compcall.name; - /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ if (resolve_compcall (e, &name) == FAILURE) @@ -5521,15 +5515,6 @@ resolve_typebound_function (gfc_expr* e) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (e, genname); - } gfc_add_component_ref (e, name); /* Recover the typespec for the expression. This is really only @@ -5552,7 +5537,6 @@ resolve_typebound_subroutine (gfc_code *code) gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; - const char *genname; const char *name; gfc_typespec ts; @@ -5577,11 +5561,6 @@ resolve_typebound_subroutine (gfc_code *code) c = gfc_find_component (declared, "$data", true, true); declared = c->ts.u.derived; - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (code->expr1->value.compcall.tbp->is_generic) - genname = code->expr1->value.compcall.name; - if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; ts = code->expr1->ts; @@ -5595,15 +5574,6 @@ resolve_typebound_subroutine (gfc_code *code) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (code->expr1, genname); - } gfc_add_component_ref (code->expr1, name); /* Recover the typespec for the expression. This is really only @@ -7505,7 +7475,7 @@ resolve_select_type (gfc_code *code) new_st->expr1->value.function.actual = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); - vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -10777,7 +10747,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false); + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } -- cgit v1.2.1 From f10a970e36b75ac92c8d636846e0a7da6af97d1f Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 14 Jul 2010 08:09:05 +0000 Subject: 2010-07-14 Janus Weil PR fortran/44925 * gfortran.h (gfc_is_data_pointer): Remove prototype. * dependency.c (gfc_is_data_pointer): Make it static. * intrinsic.texi: Update documentation on C_LOC. * resolve.c (gfc_iso_c_func_interface): Fix pointer and target checks and add a check for polymorphic variables. 2010-07-14 Janus Weil PR fortran/44925 * gfortran.dg/c_loc_tests_15.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162169 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 640a4d89fe1..15b67d46ca1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2440,10 +2440,11 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { char name[GFC_MAX_SYMBOL_LEN + 1]; char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; - int optional_arg = 0, is_pointer = 0; + int optional_arg = 0; gfc_try retval = SUCCESS; gfc_symbol *args_sym; gfc_typespec *arg_ts; + symbol_attribute arg_attr; if (args->expr->expr_type == EXPR_CONSTANT || args->expr->expr_type == EXPR_OP @@ -2460,8 +2461,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, and not necessarily that of the expr symbol (args_sym), because the actual expression could be a part-ref of the expr symbol. */ arg_ts = &(args->expr->ts); - - is_pointer = gfc_is_data_pointer (args->expr); + arg_attr = gfc_expr_attr (args->expr); if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { @@ -2504,7 +2504,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, else if (sym->intmod_sym_id == ISOCBINDING_LOC) { /* Make sure we have either the target or pointer attribute. */ - if (!args_sym->attr.target && !is_pointer) + if (!arg_attr.target && !arg_attr.pointer) { gfc_error_now ("Parameter '%s' to '%s' at %L must be either " "a TARGET or an associated pointer", @@ -2587,7 +2587,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } } } - else if (is_pointer + else if (arg_attr.pointer && is_scalar_expr_ptr (args->expr) != SUCCESS) { /* Case 1c, section 15.1.2.5, J3/04-007: an associated @@ -2622,6 +2622,13 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } + else if (arg_ts->type == BT_CLASS) + { + gfc_error_now ("Parameter '%s' to '%s' at %L must not be " + "polymorphic", args_sym->name, sym->name, + &(args->expr->where)); + retval = FAILURE; + } } } else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) -- cgit v1.2.1 From 217ca056d902a1aa0239cd570fcc474819be2bb3 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 15 Jul 2010 13:36:28 +0000 Subject: 2010-07-15 Janus Weil PR fortran/44936 * resolve.c (resolve_typebound_generic_call): Resolve generic non-polymorphic type-bound procedure calls to the correct specific procedure. (resolve_typebound_subroutine): Remove superfluous code. 2010-07-15 Janus Weil PR fortran/44936 * gfortran.dg/typebound_generic_9.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162221 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 15b67d46ca1..95dbeee43b2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5336,10 +5336,11 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) if (matches) { e->value.compcall.tbp = g->specific; + genname = g->specific_st->name; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) - *name = g->specific_st->name; + *name = genname; goto success; } } @@ -5352,12 +5353,6 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) success: /* Make sure that we have the right specific instance for the name. */ - genname = e->value.compcall.tbp->u.specific->name; - - /* Is the symtree name a "unique name". */ - if (*genname == '@') - genname = e->value.compcall.tbp->u.specific->n.sym->name; - derived = get_declared_from_expr (NULL, NULL, e); st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); @@ -5539,8 +5534,6 @@ resolve_typebound_function (gfc_expr* e) static gfc_try resolve_typebound_subroutine (gfc_code *code) { - gfc_symbol *declared; - gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; @@ -5555,7 +5548,7 @@ resolve_typebound_subroutine (gfc_code *code) return FAILURE; /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); + get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) @@ -5563,10 +5556,7 @@ resolve_typebound_subroutine (gfc_code *code) { gfc_free_ref_list (new_ref); return resolve_typebound_call (code, NULL); - } - - c = gfc_find_component (declared, "$data", true, true); - declared = c->ts.u.derived; + } if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; -- cgit v1.2.1 From abca35418102c31d95b688897b34b9ff2688ee3d Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 19 Jul 2010 18:48:44 +0000 Subject: 2010-07-19 Paul Thomas PR fortran/42385 * interface.c (matching_typebound_op): Add argument for the return of the generic name for the procedure. (build_compcall_for_operator): Add an argument for the generic name of an operator procedure and supply it to the expression. (gfc_extend_expr, gfc_extend_assign): Use the generic name in calls to the above procedures. * resolve.c (resolve_typebound_function): Catch procedure component calls for CLASS objects, check that the vtable is complete and insert the $vptr and procedure components, to make the call. (resolve_typebound_function): The same. * trans-decl.c (gfc_trans_deferred_vars): Do not deallocate an allocatable scalar if it is a result. 2010-07-19 Paul Thomas PR fortran/42385 * gfortran.dg/class_defined_operator_1.f03 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162313 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 95dbeee43b2..2434be192d7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5480,8 +5480,37 @@ resolve_typebound_function (gfc_expr* e) gfc_symtree *st; const char *name; gfc_typespec ts; + gfc_expr *expr; st = e->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = e->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && e->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : e->value.function.esym->name; + e->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (e, "$vptr"); + gfc_add_component_ref (e, name); + e->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_compcall (e, NULL); @@ -5534,13 +5563,44 @@ resolve_typebound_function (gfc_expr* e) static gfc_try resolve_typebound_subroutine (gfc_code *code) { + gfc_symbol *declared; + gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; const char *name; gfc_typespec ts; + gfc_expr *expr; st = code->expr1->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = code->expr1->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && code->expr1->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : code->expr1->value.function.esym->name; + code->expr1->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, name); + code->expr1->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_typebound_call (code, NULL); -- cgit v1.2.1