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/symbol.c | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 89cff6567bd..0c1a2fdaad0 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -809,19 +809,28 @@ duplicate_attr (const char *attr, locus *where) } +gfc_try +gfc_add_ext_attribute (symbol_attribute *attr, unsigned ext_attr, + locus *where ATTRIBUTE_UNUSED) +{ + attr->ext_attr |= 1 << ext_attr; + return SUCCESS; +} + + /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */ gfc_try gfc_add_attribute (symbol_attribute *attr, locus *where) { - if (check_used (attr, NULL, where)) return FAILURE; return check_conflict (attr, NULL, where); } + gfc_try gfc_add_allocatable (symbol_attribute *attr, locus *where) { @@ -2539,7 +2548,8 @@ save_symbol_data (gfc_symbol *sym) So if the return value is nonzero, then an error was issued. */ int -gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result) +gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, + bool allow_subroutine) { gfc_symtree *st; gfc_symbol *p; @@ -2580,11 +2590,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result) } p = st->n.sym; - if (p->ns != ns && (!p->attr.function || ns->proc_name != p) - && !(ns->proc_name - && ns->proc_name->attr.if_source == IFSRC_IFBODY - && (ns->has_import_set || p->attr.imported))) + && !(allow_subroutine && p->attr.subroutine) + && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY + && (ns->has_import_set || p->attr.imported))) { /* Symbol is from another namespace. */ gfc_error ("Symbol '%s' at %C has already been host associated", @@ -2609,7 +2618,7 @@ gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) gfc_symtree *st; int i; - i = gfc_get_sym_tree (name, ns, &st); + i = gfc_get_sym_tree (name, ns, &st, false); if (i != 0) return i; @@ -2651,7 +2660,7 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) } } - return gfc_get_sym_tree (name, gfc_current_ns, result); + return gfc_get_sym_tree (name, gfc_current_ns, result, false); } @@ -3653,7 +3662,7 @@ gen_cptr_param (gfc_formal_arglist **head, c_ptr_in = "gfc_cptr__"; else c_ptr_in = c_ptr_name; - gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree); + gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false); if (param_symtree != NULL) param_sym = param_symtree->n.sym; else @@ -3719,7 +3728,7 @@ gen_fptr_param (gfc_formal_arglist **head, if (f_ptr_name != NULL) f_ptr_out = f_ptr_name; - gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree); + gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false); if (param_symtree != NULL) param_sym = param_symtree->n.sym; else @@ -3766,7 +3775,7 @@ gen_shape_param (gfc_formal_arglist **head, if (shape_param_name != NULL) shape_param = shape_param_name; - gfc_get_sym_tree (shape_param, ns, ¶m_symtree); + gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false); if (param_symtree != NULL) param_sym = param_symtree->n.sym; else @@ -4115,7 +4124,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, return; /* Create the sym tree in the current ns. */ - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree); + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); if (tmp_symtree) tmp_sym = tmp_symtree->n.sym; else -- 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/symbol.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0c1a2fdaad0..dd06e48a305 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -3071,6 +3071,19 @@ gfc_free_finalizer_list (gfc_finalizer* list) } +/* Create a new gfc_charlen structure and add it to a namespace. */ + +gfc_charlen* +gfc_new_charlen (gfc_namespace *ns) +{ + gfc_charlen *cl; + cl = gfc_get_charlen (); + cl->next = ns->cl_list; + ns->cl_list = cl; + return cl; +} + + /* Free the charlen list from cl to end (end is not freed). Free the whole list if end is NULL. */ @@ -3927,6 +3940,9 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) formal_arg->sym->attr.flavor = FL_VARIABLE; formal_arg->sym->attr.dummy = 1; + if (formal_arg->sym->ts.type == BT_CHARACTER) + formal_arg->sym->ts.cl = gfc_new_charlen (gfc_current_ns); + /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to anything other than NULL. */ -- 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/symbol.c | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index dd06e48a305..ec4afbe0209 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -3452,6 +3452,15 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) retval = FAILURE; } + if (curr_comp->attr.proc_pointer != 0) + { + gfc_error ("Procedure pointer component '%s' at %L cannot be a member" + " of the BIND(C) derived type '%s' at %L", curr_comp->name, + &curr_comp->loc, derived_sym->name, + &derived_sym->declared_at); + retval = FAILURE; + } + /* The components cannot be allocatable. J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.allocatable != 0) -- 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/symbol.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ec4afbe0209..b86afc07358 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -810,7 +810,7 @@ duplicate_attr (const char *attr, locus *where) gfc_try -gfc_add_ext_attribute (symbol_attribute *attr, unsigned ext_attr, +gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr, locus *where ATTRIBUTE_UNUSED) { attr->ext_attr |= 1 << ext_attr; @@ -1641,6 +1641,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) { int is_proc_lang_bind_spec; + dest->ext_attr = src->ext_attr; + if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) goto fail; -- 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/symbol.c | 101 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 90 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b86afc07358..c2666ae7e49 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2220,7 +2220,10 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types) ns->parent = parent; for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) - ns->operator_access[in] = ACCESS_UNKNOWN; + { + ns->operator_access[in] = ACCESS_UNKNOWN; + ns->tb_op[in] = NULL; + } /* Initialize default implicit types. */ for (i = 'a'; i <= 'z'; i++) @@ -2948,7 +2951,6 @@ free_common_tree (gfc_symtree * common_tree) static void free_uop_tree (gfc_symtree *uop_tree) { - if (uop_tree == NULL) return; @@ -2956,7 +2958,6 @@ free_uop_tree (gfc_symtree *uop_tree) free_uop_tree (uop_tree->right); gfc_free_interface (uop_tree->n.uop->op); - gfc_free (uop_tree->n.uop); gfc_free (uop_tree); } @@ -3128,6 +3129,7 @@ gfc_free_namespace (gfc_namespace *ns) free_uop_tree (ns->uop_root); free_common_tree (ns->common_root); free_tb_tree (ns->tb_sym_root); + free_tb_tree (ns->tb_uop_root); gfc_free_finalizer_list (ns->finalizers); gfc_free_charlen (ns->cl_list, NULL); free_st_labels (ns->st_labels); @@ -4519,22 +4521,27 @@ gfc_get_derived_super_type (gfc_symbol* derived) } -/* Find a type-bound procedure by name for a derived-type (looking recursively - through the super-types). */ +/* General worker function to find either a type-bound procedure or a + type-bound user operator. */ -gfc_symtree* -gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) +static gfc_symtree* +find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess, bool uop) { gfc_symtree* res; + gfc_symtree* root; + + /* Set correct symbol-root. */ + gcc_assert (derived->f2k_derived); + root = (uop ? derived->f2k_derived->tb_uop_root + : derived->f2k_derived->tb_sym_root); /* Set default to failure. */ if (t) *t = FAILURE; /* Try to find it in the current type's namespace. */ - gcc_assert (derived->f2k_derived); - res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name); + res = gfc_find_symtree (root, name); if (res && res->n.tb) { /* We found one. */ @@ -4558,7 +4565,79 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, gfc_symbol* super_type; super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return gfc_find_typebound_proc (super_type, t, name, noaccess); + + return find_typebound_proc_uop (super_type, t, name, noaccess, uop); + } + + /* Nothing found. */ + return NULL; +} + + +/* Find a type-bound procedure or user operator by name for a derived-type + (looking recursively through the super-types). */ + +gfc_symtree* +gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, false); +} + +gfc_symtree* +gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, true); +} + + +/* Find a type-bound intrinsic operator looking recursively through the + super-type hierarchy. */ + +gfc_typebound_proc* +gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, + gfc_intrinsic_op op, bool noaccess) +{ + gfc_typebound_proc* res; + + /* Set default to failure. */ + if (t) + *t = FAILURE; + + /* Try to find it in the current type's namespace. */ + if (derived->f2k_derived) + res = derived->f2k_derived->tb_op[op]; + else + res = NULL; + + /* Check access. */ + if (res) + { + /* We found one. */ + if (t) + *t = SUCCESS; + + if (!noaccess && derived->attr.use_assoc + && res->access == ACCESS_PRIVATE) + { + gfc_error ("'%s' of '%s' is PRIVATE at %C", + gfc_op2string (op), derived->name); + if (t) + *t = FAILURE; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess); } /* Nothing found. */ -- cgit v1.2.1 From 0266d75cdea0b4faaead7bc55388fd06cceb911c Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 12 Aug 2009 09:03:38 +0000 Subject: 2009-08-12 Tobias Burnus PR fortran/41034 * symbol.c (gfc_copy_attr): Merge bits instead of replace bits in gfc_copy_attr. * gfc_check_pointer_assign (gfc_check_pointer_assign): Initialize ext_attr bits by zero. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150678 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c2666ae7e49..27f378c1b18 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1641,7 +1641,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) { int is_proc_lang_bind_spec; - dest->ext_attr = src->ext_attr; + /* In line with the other attributes, we only add bits but do not remove + them; cf. also PR 41034. */ + dest->ext_attr |= src->ext_attr; if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) goto fail; @@ -1712,7 +1714,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE) goto fail; if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE) - goto fail; + goto fail; is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); if (src->is_bind_c -- 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/symbol.c | 62 ++++++++++++++++++++++++++-------------------------- 1 file changed, 31 insertions(+), 31 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 27f378c1b18..dc10bc69e48 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -269,10 +269,10 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) sym->ts = *ts; sym->attr.implicit_type = 1; - if (ts->cl) + if (ts->type == BT_CHARACTER && ts->u.cl) { - sym->ts.cl = gfc_get_charlen (); - *sym->ts.cl = *ts->cl; + sym->ts.u.cl = gfc_get_charlen (); + *sym->ts.u.cl = *ts->u.cl; } if (sym->attr.is_bind_c == 1) @@ -1774,10 +1774,10 @@ gfc_add_component (gfc_symbol *sym, const char *name, } if (sym->attr.extension - && gfc_find_component (sym->components->ts.derived, name, true, true)) + && gfc_find_component (sym->components->ts.u.derived, name, true, true)) { gfc_error ("Component '%s' at %C already in the parent type " - "at %L", name, &sym->components->ts.derived->declared_at); + "at %L", name, &sym->components->ts.u.derived->declared_at); return FAILURE; } @@ -1810,8 +1810,8 @@ switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) return; sym = st->n.sym; - if (sym->ts.type == BT_DERIVED && sym->ts.derived == from) - sym->ts.derived = to; + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from) + sym->ts.u.derived = to; switch_types (st->left, from, to); switch_types (st->right, from, to); @@ -1863,8 +1863,8 @@ gfc_use_derived (gfc_symbol *sym) for (i = 0; i < GFC_LETTERS; i++) { t = &sym->ns->default_type[i]; - if (t->derived == sym) - t->derived = s; + if (t->u.derived == sym) + t->u.derived = s; } st = gfc_find_symtree (sym->ns->sym_root, sym->name); @@ -1917,7 +1917,7 @@ gfc_find_component (gfc_symbol *sym, const char *name, && sym->attr.extension && sym->components->ts.type == BT_DERIVED) { - p = gfc_find_component (sym->components->ts.derived, name, + p = gfc_find_component (sym->components->ts.u.derived, name, noaccess, silent); /* Do not overwrite the error. */ if (p == NULL) @@ -3263,8 +3263,8 @@ gfc_is_var_automatic (gfc_symbol *sym) return true; /* Check for non-constant length character variables. */ if (sym->ts.type == BT_CHARACTER - && sym->ts.cl - && !gfc_is_constant_expr (sym->ts.cl->length)) + && sym->ts.u.cl + && !gfc_is_constant_expr (sym->ts.u.cl->length)) return true; return false; } @@ -3481,14 +3481,14 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) /* BIND(C) derived types must have interoperable components. */ if (curr_comp->ts.type == BT_DERIVED - && curr_comp->ts.derived->ts.is_iso_c != 1 - && curr_comp->ts.derived != derived_sym) + && curr_comp->ts.u.derived->ts.is_iso_c != 1 + && curr_comp->ts.u.derived != derived_sym) { /* This should be allowed; the draft says a derived-type can not have type parameters if it is has the BIND attribute. Type parameters seem to be for making parameterized derived types. There's no need to verify the type if it is c_ptr/c_funptr. */ - retval = verify_bind_c_derived_type (curr_comp->ts.derived); + retval = verify_bind_c_derived_type (curr_comp->ts.u.derived); } else { @@ -3587,10 +3587,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, /* The c_ptr and c_funptr derived types will provide the definition for c_null_ptr and c_null_funptr, respectively. */ if (ptr_id == ISOCBINDING_NULL_PTR) - tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR); + tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR); else - tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); - if (tmp_sym->ts.derived == NULL) + tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); + if (tmp_sym->ts.u.derived == NULL) { /* This can occur if the user forgot to declare c_ptr or c_funptr and they're trying to use one of the procedures @@ -3603,7 +3603,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, ? "_gfortran_iso_c_binding_c_ptr" : "_gfortran_iso_c_binding_c_funptr")); - tmp_sym->ts.derived = + tmp_sym->ts.u.derived = get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR); } @@ -3624,7 +3624,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, tmp_sym->value = gfc_get_expr (); tmp_sym->value->expr_type = EXPR_STRUCTURE; tmp_sym->value->ts.type = BT_DERIVED; - tmp_sym->value->ts.derived = tmp_sym->ts.derived; + tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; /* Create a constructor with no expr, that way we can recognize if the user tries to call the structure constructor for one of the iso_c_binding derived types during resolution (resolve_structure_cons). */ @@ -3728,7 +3728,7 @@ gen_cptr_param (gfc_formal_arglist **head, gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym)); } - param_sym->ts.derived = c_ptr_sym; + param_sym->ts.u.derived = c_ptr_sym; param_sym->module = gfc_get_string (module_name); /* Make new formal arg. */ @@ -3956,7 +3956,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) formal_arg->sym->attr.dummy = 1; if (formal_arg->sym->ts.type == BT_CHARACTER) - formal_arg->sym->ts.cl = gfc_new_charlen (gfc_current_ns); + formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to @@ -4219,8 +4219,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->value->value.character.string[0] = (gfc_char_t) c_interop_kinds_table[s].value; tmp_sym->value->value.character.string[1] = '\0'; - tmp_sym->ts.cl = gfc_get_charlen (); - tmp_sym->ts.cl->length = gfc_int_expr (1); + tmp_sym->ts.u.cl = gfc_get_charlen (); + tmp_sym->ts.u.cl->length = gfc_int_expr (1); /* May not need this in both attr and ts, but do need in attr for writing module file. */ @@ -4264,7 +4264,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->attr.referenced = 1; - tmp_sym->ts.derived = tmp_sym; + tmp_sym->ts.u.derived = tmp_sym; /* Add the symbol created for the derived type to the current ns. */ dt_list_ptr = &(gfc_derived_types); @@ -4349,13 +4349,13 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, C address of. */ tmp_sym->ts.type = BT_DERIVED; if (s == ISOCBINDING_LOC) - tmp_sym->ts.derived = + tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR); else - tmp_sym->ts.derived = + tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); - if (tmp_sym->ts.derived == NULL) + if (tmp_sym->ts.u.derived == NULL) { /* Create the necessary derived type so we can continue processing the file. */ @@ -4365,7 +4365,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, (const char *)(s == ISOCBINDING_FUNLOC ? "_gfortran_iso_c_binding_c_funptr" : "_gfortran_iso_c_binding_c_ptr")); - tmp_sym->ts.derived = + tmp_sym->ts.u.derived = get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR); @@ -4517,9 +4517,9 @@ gfc_get_derived_super_type (gfc_symbol* derived) gcc_assert (derived->components); gcc_assert (derived->components->ts.type == BT_DERIVED); - gcc_assert (derived->components->ts.derived); + gcc_assert (derived->components->ts.u.derived); - return derived->components->ts.derived; + return derived->components->ts.u.derived; } -- 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/symbol.c | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index dc10bc69e48..8e4f6e9a114 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -270,10 +270,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) sym->attr.implicit_type = 1; if (ts->type == BT_CHARACTER && ts->u.cl) - { - sym->ts.u.cl = gfc_get_charlen (); - *sym->ts.u.cl = *ts->u.cl; - } + sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl); if (sym->attr.is_bind_c == 1) { @@ -3076,15 +3073,29 @@ gfc_free_finalizer_list (gfc_finalizer* list) } -/* Create a new gfc_charlen structure and add it to a namespace. */ +/* Create a new gfc_charlen structure and add it to a namespace. + If 'old_cl' is given, the newly created charlen will be a copy of it. */ gfc_charlen* -gfc_new_charlen (gfc_namespace *ns) +gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) { gfc_charlen *cl; cl = gfc_get_charlen (); + + /* Put into namespace. */ cl->next = ns->cl_list; ns->cl_list = cl; + + /* Copy old_cl. */ + if (old_cl) + { + cl->length = gfc_copy_expr (old_cl->length); + cl->length_from_typespec = old_cl->length_from_typespec; + cl->backend_decl = old_cl->backend_decl; + cl->passed_length = old_cl->passed_length; + cl->resolved = old_cl->resolved; + } + return cl; } @@ -3956,7 +3967,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) formal_arg->sym->attr.dummy = 1; if (formal_arg->sym->ts.type == BT_CHARACTER) - formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns); + formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to @@ -4219,7 +4230,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->value->value.character.string[0] = (gfc_char_t) c_interop_kinds_table[s].value; tmp_sym->value->value.character.string[1] = '\0'; - tmp_sym->ts.u.cl = gfc_get_charlen (); + tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); tmp_sym->ts.u.cl->length = gfc_int_expr (1); /* May not need this in both attr and ts, but do need in -- 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/symbol.c | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8e4f6e9a114..150d14952b3 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4539,7 +4539,8 @@ gfc_get_derived_super_type (gfc_symbol* derived) static gfc_symtree* find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, bool uop) + const char* name, bool noaccess, bool uop, + locus* where) { gfc_symtree* res; gfc_symtree* root; @@ -4555,7 +4556,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, /* Try to find it in the current type's namespace. */ res = gfc_find_symtree (root, name); - if (res && res->n.tb) + if (res && res->n.tb && !res->n.tb->error) { /* We found one. */ if (t) @@ -4564,7 +4565,9 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, if (!noaccess && derived->attr.use_assoc && res->n.tb->access == ACCESS_PRIVATE) { - gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name); + if (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + name, derived->name, where); if (t) *t = FAILURE; } @@ -4579,7 +4582,8 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return find_typebound_proc_uop (super_type, t, name, noaccess, uop); + return find_typebound_proc_uop (super_type, t, name, + noaccess, uop, where); } /* Nothing found. */ @@ -4592,16 +4596,16 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, gfc_symtree* gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) + const char* name, bool noaccess, locus* where) { - return find_typebound_proc_uop (derived, t, name, noaccess, false); + return find_typebound_proc_uop (derived, t, name, noaccess, false, where); } gfc_symtree* gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess) + const char* name, bool noaccess, locus* where) { - return find_typebound_proc_uop (derived, t, name, noaccess, true); + return find_typebound_proc_uop (derived, t, name, noaccess, true, where); } @@ -4610,7 +4614,8 @@ gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, - gfc_intrinsic_op op, bool noaccess) + gfc_intrinsic_op op, bool noaccess, + locus* where) { gfc_typebound_proc* res; @@ -4625,7 +4630,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, res = NULL; /* Check access. */ - if (res) + if (res && !res->error) { /* We found one. */ if (t) @@ -4634,8 +4639,9 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, if (!noaccess && derived->attr.use_assoc && res->access == ACCESS_PRIVATE) { - gfc_error ("'%s' of '%s' is PRIVATE at %C", - gfc_op2string (op), derived->name); + if (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_op2string (op), derived->name, where); if (t) *t = FAILURE; } @@ -4650,7 +4656,8 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); - return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess); + return gfc_find_typebound_intrinsic_op (super_type, t, op, + noaccess, where); } /* Nothing found. */ -- cgit v1.2.1 From e8152f13490bf1b3e3a94c318d83a750d562e5b2 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 31 Aug 2009 19:08:03 +0000 Subject: 2009-08-31 Janus Weil Paul Thomas PR fortran/40940 * array.c (gfc_match_array_constructor): Rename gfc_match_type_spec. * decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec, and reject CLASS with -std=f95. (gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix, match_procedure_interface): Rename gfc_match_type_spec. * gfortran.h (gfc_type_compatible): Add prototype. * match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec. * match.c (match_intrinsic_typespec): Rename to match_type_spec, and add handling of derived types. (gfc_match_allocate): Rename match_intrinsic_typespec and check type compatibility of derived types. * symbol.c (gfc_type_compatible): New function to check if two types are compatible. 2009-08-31 Janus Weil PR fortran/40940 * gfortran.dg/allocate_derived_1.f90: New. * gfortran.dg/class_3.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151244 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 150d14952b3..f6ce3cfce82 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4534,6 +4534,32 @@ gfc_get_derived_super_type (gfc_symbol* derived) } +/* Check if two typespecs are type compatible (F03:5.1.1.2): + If ts1 is nonpolymorphic, ts2 must be the same type. + If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ + +bool +gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) +{ + if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED) + { + gfc_symbol *t0, *t; + if (ts1->is_class) + { + t0 = ts1->u.derived; + t = ts2->u.derived; + while (t0 != t && t->attr.extension) + t = gfc_get_derived_super_type (t); + return (t0 == t); + } + else + return (ts1->u.derived == ts2->u.derived); + } + else + return (ts1->type == ts2->type); +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ -- 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/symbol.c | 54 +++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 43 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index f6ce3cfce82..39285b16fea 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2644,6 +2644,13 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) int i; i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + + /* Special case: If we're in a SELECT TYPE block, + replace the selector variable by a temporary. */ + if (gfc_current_state () == COMP_SELECT_TYPE + && st && st->n.sym == type_selector) + st = select_type_tmp; + if (st != NULL) { save_symbol_data (st->n.sym); @@ -4534,6 +4541,34 @@ gfc_get_derived_super_type (gfc_symbol* derived) } +/* Get the ultimate super-type of a given derived type. */ + +gfc_symbol* +gfc_get_ultimate_derived_super_type (gfc_symbol* derived) +{ + if (!derived->attr.extension) + return NULL; + + derived = gfc_get_derived_super_type (derived); + + if (derived->attr.extension) + return gfc_get_ultimate_derived_super_type (derived); + else + return derived; +} + + +/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ + +bool +gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) +{ + while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) + t2 = gfc_get_derived_super_type (t2); + return gfc_compare_derived_types (t1, t2); +} + + /* Check if two typespecs are type compatible (F03:5.1.1.2): If ts1 is nonpolymorphic, ts2 must be the same type. If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ @@ -4541,19 +4576,16 @@ gfc_get_derived_super_type (gfc_symbol* derived) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED) + if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) + && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) { - gfc_symbol *t0, *t; - if (ts1->is_class) - { - t0 = ts1->u.derived; - t = ts2->u.derived; - while (t0 != t && t->attr.extension) - t = gfc_get_derived_super_type (t); - return (t0 == t); - } + if (ts1->type == BT_CLASS) + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived); + else if (ts2->type != BT_CLASS) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); else - return (ts1->u.derived == ts2->u.derived); + return 0; } else return (ts1->type == ts2->type); -- 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/symbol.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 39285b16fea..8cd18db0a8f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4579,9 +4579,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) { - if (ts1->type == BT_CLASS) + if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED) return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, ts2->u.derived); + else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS) + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived->components->ts.u.derived); else if (ts2->type != BT_CLASS) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); else -- 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/symbol.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8cd18db0a8f..befa90b8c49 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2479,6 +2479,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, st = gfc_find_symtree (ns->sym_root, name); if (st != NULL) { + /* Special case: If we're in a SELECT TYPE block, + replace the selector variable by a temporary. */ + if (gfc_current_state () == COMP_SELECT_TYPE + && st && st->n.sym == type_selector) + st = select_type_tmp; + *result = st; /* Ambiguous generic interfaces are permitted, as long as the specific interfaces are different. */ @@ -2645,12 +2651,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); - /* Special case: If we're in a SELECT TYPE block, - replace the selector variable by a temporary. */ - if (gfc_current_state () == COMP_SELECT_TYPE - && st && st->n.sym == type_selector) - st = select_type_tmp; - if (st != NULL) { save_symbol_data (st->n.sym); -- cgit v1.2.1 From c151eaabaf50c3360ef47e70c15abd146ad11cd1 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 9 Oct 2009 20:25:19 +0000 Subject: 2009-10-09 Janus Weil PR fortran/41579 * gfortran.h (gfc_select_type_stack): New struct, to be used as a stack for SELECT TYPE statements. (select_type_stack): New global variable. (type_selector,select_type_tmp): Removed. * match.c (type_selector,type_selector): Removed. (select_type_stack): New variable, serving as a stack for SELECT TYPE statements. (select_type_push,select_type_set_tmp): New functions. (gfc_match_select_type): Call select_type_push. (gfc_match_type_is): Call select_type_set_tmp. * parse.c (select_type_pop): New function. (parse_select_type_block): Call select_type_pop. * symbol.c (select_type_insert_tmp): New function. (gfc_find_sym_tree): Call select_type_insert_tmp. 2009-10-09 Janus Weil PR fortran/41579 * gfortran.dg/select_type_6.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152600 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index befa90b8c49..2641df82b35 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2461,6 +2461,19 @@ ambiguous_symbol (const char *name, gfc_symtree *st) } +/* If we're in a SELECT TYPE block, check if the variable 'st' matches any + selector on the stack. If yes, replace it by the corresponding temporary. */ + +static void +select_type_insert_tmp (gfc_symtree **st) +{ + gfc_select_type_stack *stack = select_type_stack; + for (; stack; stack = stack->prev) + if ((*st)->n.sym == stack->selector) + *st = stack->tmp; +} + + /* Search for a symtree starting in the current namespace, resorting to any parent namespaces if requested by a nonzero parent_flag. Returns nonzero if the name is ambiguous. */ @@ -2479,11 +2492,7 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, st = gfc_find_symtree (ns->sym_root, name); if (st != NULL) { - /* Special case: If we're in a SELECT TYPE block, - replace the selector variable by a temporary. */ - if (gfc_current_state () == COMP_SELECT_TYPE - && st && st->n.sym == type_selector) - st = select_type_tmp; + select_type_insert_tmp (&st); *result = st; /* Ambiguous generic interfaces are permitted, as long -- cgit v1.2.1 From 7ba65099b4d888030fcb580d65907ceff6fe9e69 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 19 Oct 2009 18:03:02 +0000 Subject: 2009-10-19 Tobias Burnus Steven G. Kargl PR fortran/41755 * symbol.c (gfc_undo_symbols): Add NULL check. * match.c (gfc_match_equivalence): Add check for missing comma. 2009-10-19 Tobias Burnus PR fortran/41755 * gfortran.dg/equiv_8.f90: New test. * gfortran.dg/class_allocate_1.f03: Remove obsolete FIXME. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152983 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 2641df82b35..837a357d9fb 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2741,7 +2741,7 @@ gfc_undo_symbols (void) if (p->gfc_new) { /* Symbol was new. */ - if (p->attr.in_common && p->common_block->head) + if (p->attr.in_common && p->common_block && p->common_block->head) { /* If the symbol was added to any common block, it needs to be removed to stop the resolver looking -- 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/symbol.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 837a357d9fb..c1b39b0d9f1 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2030,9 +2030,16 @@ gfc_st_label * gfc_get_st_label (int labelno) { gfc_st_label *lp; + gfc_namespace *ns; + + /* Find the namespace of the scoping unit: + If we're in a BLOCK construct, jump to the parent namespace. */ + ns = gfc_current_ns; + while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL) + ns = ns->parent; /* First see if the label is already in this namespace. */ - lp = gfc_current_ns->st_labels; + lp = ns->st_labels; while (lp) { if (lp->value == labelno) @@ -2050,7 +2057,7 @@ gfc_get_st_label (int labelno) lp->defined = ST_LABEL_UNKNOWN; lp->referenced = ST_LABEL_UNKNOWN; - gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels); + gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); return lp; } -- 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/symbol.c | 232 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 219 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c1b39b0d9f1..6dd0a8afa0f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1045,7 +1045,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - if (attr->save == SAVE_EXPLICIT) + if (attr->save == SAVE_EXPLICIT && !attr->vtab) { if (gfc_notify_std (GFC_STD_LEGACY, "Duplicate SAVE attribute specified at %L", @@ -4592,22 +4592,228 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) - && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) + gfc_component *cmp1, *cmp2; + + bool is_class1 = (ts1->type == BT_CLASS); + bool is_class2 = (ts2->type == BT_CLASS); + bool is_derived1 = (ts1->type == BT_DERIVED); + bool is_derived2 = (ts2->type == BT_DERIVED); + + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) + return (ts1->type == ts2->type); + + if (is_derived1 && is_derived2) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); + + cmp1 = cmp2 = NULL; + + if (is_class1) { - if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived); - else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived->components->ts.u.derived); - else if (ts2->type != BT_CLASS) - return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - else + cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false); + if (cmp1 == NULL) return 0; } + + if (is_class2) + { + cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false); + if (cmp2 == NULL) + return 0; + } + + if (is_class1 && is_derived2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived); + + else if (is_class1 && is_class2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived); + else - return (ts1->type == ts2->type); + return 0; +} + + +/* Build a polymorphic CLASS entity, using the symbol that comes from + build_sym. A CLASS entity is represented by an encapsulating type, + which contains the declared type as '$data' component, plus a pointer + component '$vptr' which determines the dynamic type. */ + +gfc_try +gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, + gfc_array_spec **as) +{ + char name[GFC_MAX_SYMBOL_LEN + 5]; + gfc_symbol *fclass; + gfc_symbol *vtab; + gfc_component *c; + + /* Determine the name of the encapsulating type. */ + if ((*as) && (*as)->rank && attr->allocatable) + sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); + else if ((*as) && (*as)->rank) + sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + else if (attr->allocatable) + sprintf (name, ".class.%s.a", ts->u.derived->name); + else + sprintf (name, ".class.%s", ts->u.derived->name); + + gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); + if (fclass == NULL) + { + gfc_symtree *st; + /* If not there, create a new symbol. */ + fclass = gfc_new_symbol (name, ts->u.derived->ns); + st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); + st->n.sym = fclass; + gfc_set_sym_referenced (fclass); + fclass->refs++; + fclass->ts.type = BT_UNKNOWN; + fclass->attr.abstract = ts->u.derived->attr.abstract; + if (ts->u.derived->f2k_derived) + fclass->f2k_derived = gfc_get_namespace (NULL, 0); + if (gfc_add_flavor (&fclass->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return FAILURE; + + /* Add component '$data'. */ + if (gfc_add_component (fclass, "$data", &c) == FAILURE) + return FAILURE; + c->ts = *ts; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->ts.u.derived = ts->u.derived; + c->attr.pointer = attr->pointer || attr->dummy; + c->attr.allocatable = attr->allocatable; + c->attr.dimension = attr->dimension; + c->attr.abstract = ts->u.derived->attr.abstract; + c->as = (*as); + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; + + /* Add component '$vptr'. */ + if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_DERIVED; + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + c->attr.pointer = 1; + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; + } + + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type '%s' at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return FAILURE; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.is_class = 1; + ts->u.derived = fclass; + attr->allocatable = attr->pointer = attr->dimension = 0; + (*as) = NULL; /* XXX */ + return SUCCESS; +} + + +/* Find the symbol for a derived type's vtab. */ + +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL; + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + + ns = gfc_current_ns; + + for (; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (ns) + { + sprintf (name, "vtab$%s", derived->name); + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + vtab->attr.flavor = FL_VARIABLE; + vtab->attr.target = 1; + vtab->attr.save = SAVE_EXPLICIT; + vtab->attr.vtab = 1; + vtab->refs++; + gfc_set_sym_referenced (vtab); + sprintf (name, "vtype$%s", derived->name); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + gfc_symbol *parent = NULL, *parent_vtab = NULL; + + gfc_get_symbol (name, ns, &vtype); + if (gfc_add_flavor (&vtype->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return NULL; + vtype->refs++; + gfc_set_sym_referenced (vtype); + + /* Add component '$hash'. */ + if (gfc_add_component (vtype, "$hash", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (derived->hash_value); + + /* Add component '$size'. */ + if (gfc_add_component (vtype, "$size", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + /* Remember the derived type in ts.u.derived, + so that the correct initializer can be set later on + (in gfc_conv_structure). */ + c->ts.u.derived = derived; + c->initializer = gfc_int_expr (0); + + /* Add component $extends. */ + if (gfc_add_component (vtype, "$extends", &c) == FAILURE) + return NULL; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_get_expr (); + parent = gfc_get_derived_super_type (derived); + if (parent) + { + parent_vtab = gfc_find_derived_vtab (parent); + c->ts.type = BT_DERIVED; + c->ts.u.derived = parent_vtab->ts.u.derived; + c->initializer->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, + &c->initializer->symtree); + } + else + { + c->ts.type = BT_DERIVED; + c->ts.u.derived = vtype; + c->initializer->expr_type = EXPR_NULL; + } + } + vtab->ts.u.derived = vtype; + + vtab->value = gfc_default_initializer (&vtab->ts); + } + } + + return vtab; } -- 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/symbol.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6dd0a8afa0f..08477c4f577 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4681,6 +4681,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.type = BT_DERIVED; c->attr.access = ACCESS_PRIVATE; c->ts.u.derived = ts->u.derived; + c->attr.class_pointer = attr->pointer; c->attr.pointer = attr->pointer || attr->dummy; c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; -- cgit v1.2.1 From b74c019cc5ae3f52f30a39bff4d7a50417bdef74 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 11 Dec 2009 14:40:36 +0000 Subject: gcc/fortran/ 2009-12-11 Janus Weil PR fortran/42335 * symbol.c (select_type_insert_tmp): Add an extra check for error recovery. gcc/testsuite/ 2009-12-11 Janus Weil PR fortran/42335 * gfortran.dg/select_type_11.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155162 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 08477c4f577..1b40d9a549a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2476,7 +2476,7 @@ select_type_insert_tmp (gfc_symtree **st) { gfc_select_type_stack *stack = select_type_stack; for (; stack; stack = stack->prev) - if ((*st)->n.sym == stack->selector) + if ((*st)->n.sym == stack->selector && stack->tmp) *st = stack->tmp; } -- cgit v1.2.1 From 30dbd42025bff2741fc0f2a3c1b3f0f29881ce95 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 28 Dec 2009 23:13:03 +0000 Subject: gcc/fortran/ 2009-12-28 Janus Weil PR fortran/42353 * symbol.c (gfc_find_derived_vtab): Make vtabs and vtypes private. gcc/testsuite/ 2009-12-28 Janus Weil PR fortran/42353 * gfortran.dg/class_13.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155494 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 1b40d9a549a..8ba5adb51c2 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4748,6 +4748,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.target = 1; vtab->attr.save = SAVE_EXPLICIT; vtab->attr.vtab = 1; + vtab->attr.access = ACCESS_PRIVATE; vtab->refs++; gfc_set_sym_referenced (vtab); sprintf (name, "vtype$%s", derived->name); @@ -4764,6 +4765,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) return NULL; vtype->refs++; gfc_set_sym_referenced (vtype); + vtype->attr.access = ACCESS_PRIVATE; /* Add component '$hash'. */ if (gfc_add_component (vtype, "$hash", &c) == 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 flavor); @@ -598,6 +603,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dimension); conf2 (dummy); conf2 (volatile_); + conf2 (asynchronous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -640,8 +646,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) if (attr->subroutine) { + a1 = subroutine; conf2 (target); conf2 (allocatable); + conf2 (volatile_); + conf2 (asynchronous); conf2 (in_namelist); conf2 (dimension); conf2 (function); @@ -708,6 +717,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (in_common); conf2 (value); conf2 (volatile_); + conf2 (asynchronous); conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); @@ -1099,6 +1109,25 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) } +gfc_try +gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) +{ + /* No check_used needed as 11.2.1 of the F2003 standard allows + that the local identifier made accessible by a use statement can be + given a ASYNCHRONOUS attribute. */ + + if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) + if (gfc_notify_std (GFC_STD_LEGACY, + "Duplicate ASYNCHRONOUS attribute specified at %L", + where) == FAILURE) + return FAILURE; + + attr->asynchronous = 1; + attr->asynchronous_ns = gfc_current_ns; + return check_conflict (attr, name, where); +} + + gfc_try gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) { @@ -1659,6 +1688,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE) goto fail; + if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE) + goto fail; if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE) goto fail; -- cgit v1.2.1 From 650ee6fba83f72c04ec73f880703190eea76136c Mon Sep 17 00:00:00 2001 From: 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/symbol.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 750aa2d6a16..a5787de04ab 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1,6 +1,6 @@ /* Maintain binary trees of symbols. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -3690,10 +3690,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, tmp_sym->value->expr_type = EXPR_STRUCTURE; tmp_sym->value->ts.type = BT_DERIVED; tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; - /* Create a constructor with no expr, that way we can recognize if the user - tries to call the structure constructor for one of the iso_c_binding - derived types during resolution (resolve_structure_cons). */ tmp_sym->value->value.constructor = gfc_get_constructor (); + tmp_sym->value->value.constructor->expr = gfc_get_expr (); + tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL; + tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1; /* Must declare c_null_ptr and c_null_funptr as having the PARAMETER attribute so they can be used in init expressions. */ tmp_sym->attr.flavor = FL_PARAMETER; -- 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/symbol.c | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index a5787de04ab..e363c5e2703 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1958,23 +1958,17 @@ gfc_find_component (gfc_symbol *sym, const char *name, else if (sym->attr.use_assoc && !noaccess) { - if (p->attr.access == ACCESS_PRIVATE) + bool is_parent_comp = sym->attr.extension && (p == sym->components); + if (p->attr.access == ACCESS_PRIVATE || + (p->attr.access != ACCESS_PUBLIC + && sym->component_access == ACCESS_PRIVATE + && !is_parent_comp)) { if (!silent) gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", name, sym->name); return NULL; } - - /* If there were components given and all components are private, error - out at this place. */ - if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE) - { - if (!silent) - gfc_error ("All components of '%s' are PRIVATE in structure" - " constructor at %C", sym->name); - return NULL; - } } return p; -- cgit v1.2.1 From 372720b042d1ce9f3da3e17eb031557fe36e7863 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 10 Mar 2010 18:56:46 +0000 Subject: 2010-03-10 Tobias Burnus result. 2010-03-10 Tobias Burnus n.sym->module = gfc_get_string (old_sym->module); new_symtree->n.sym->from_intmod = old_sym->from_intmod; new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id; + if (old_sym->attr.function) + new_symtree->n.sym->result = new_symtree->n.sym; /* Build the formal arg list. */ build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg); -- cgit v1.2.1 From 1384ae99ee84aa34f559ffb29468099e22d88dd2 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 1 Apr 2010 18:06:05 +0000 Subject: 2010-04-01 Paul Thomas * ioparm.def : Update copyright. * lang.opt : ditto * trans-array.c : ditto * trans-array.h : ditto * expr.c: ditto * trans-types.c: ditto * dependency.c : ditto * gfortran.h : ditto * options.c : ditto * trans-io.c : ditto * trans-intrinsic.c : ditto * libgfortran.h : ditto * invoke.texi : ditto * intrinsic.texi : ditto * trans.c : ditto * trans.h : ditto * intrinsic.c : ditto * interface.c : ditto * iresolve.c : ditto * trans-stmt.c : ditto * trans-stmt.h : ditto * parse,c : ditto * match.h : ditto * error.c : ditto git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157923 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0cbbacc2308..98af7550f22 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1,6 +1,7 @@ /* Maintain binary trees of symbols. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009, 2010 Free Software Foundation, Inc. + 2009, 2010 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. -- 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/symbol.c | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 98af7550f22..dbbc97c78cd 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -371,7 +371,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -477,11 +477,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_common, dummy); conf (in_common, allocatable); + conf (in_common, codimension); conf (in_common, result); conf (dummy, result); conf (in_equivalence, use_assoc); + conf (in_equivalence, codimension); conf (in_equivalence, dummy); conf (in_equivalence, target); conf (in_equivalence, pointer); @@ -503,6 +505,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (is_bind_c, cray_pointer); conf (is_bind_c, cray_pointee); + conf (is_bind_c, codimension); conf (is_bind_c, allocatable); conf (is_bind_c, elemental); @@ -513,6 +516,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) /* Cray pointer/pointee conflicts. */ conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); + conf (cray_pointer, codimension); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -524,6 +528,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); conf (cray_pointee, dummy); @@ -547,8 +552,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (value, function) conf (value, volatile_) conf (value, dimension) + conf (value, codimension) conf (value, external) + conf (codimension, result) + if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) { @@ -576,6 +584,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, allocatable) conf (procedure, dimension) + conf (procedure, codimension) conf (procedure, intrinsic) conf (procedure, is_protected) conf (procedure, target) @@ -601,6 +610,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: + conf2 (codimension); conf2 (dimension); conf2 (dummy); conf2 (volatile_); @@ -653,6 +663,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (in_namelist); + conf2 (codimension); conf2 (dimension); conf2 (function); conf2 (threadprivate); @@ -722,6 +733,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); + conf2 (codimension); conf2 (result); break; @@ -865,6 +877,32 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) } +gfc_try +gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->codimension) + { + duplicate_attr ("CODIMENSION", where); + return FAILURE; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE) + { + gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body " + "at %L", name, where); + return FAILURE; + } + + attr->codimension = 1; + return check_conflict (attr, name, where); +} + + gfc_try gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) { @@ -1096,7 +1134,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) { /* No check_used needed as 11.2.1 of the F2003 standard allows that the local identifier made accessible by a use statement can be - given a VOLATILE attribute. */ + given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) if (gfc_notify_std (GFC_STD_LEGACY, @@ -1677,6 +1715,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) goto fail; + if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) @@ -4713,6 +4753,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.pointer = attr->pointer || attr->dummy; c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; + c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); c->initializer = gfc_get_expr (); -- 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/symbol.c | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index dbbc97c78cd..4356845e206 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "parse.h" #include "match.h" +#include "constructor.h" /* Strings for all symbol attributes. We use these for dumping the @@ -3664,6 +3665,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, { gfc_symtree *tmp_symtree; gfc_symbol *tmp_sym; + gfc_constructor *c; tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name); @@ -3725,10 +3727,11 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, tmp_sym->value->expr_type = EXPR_STRUCTURE; tmp_sym->value->ts.type = BT_DERIVED; tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; - tmp_sym->value->value.constructor = gfc_get_constructor (); - tmp_sym->value->value.constructor->expr = gfc_get_expr (); - tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL; - tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1; + gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); + c = gfc_constructor_first (tmp_sym->value->value.constructor); + c->expr = gfc_get_expr (); + c->expr->expr_type = EXPR_NULL; + c->expr->ts.is_iso_c = 1; /* Must declare c_null_ptr and c_null_funptr as having the PARAMETER attribute so they can be used in init expressions. */ tmp_sym->attr.flavor = FL_PARAMETER; @@ -3934,7 +3937,8 @@ gen_shape_param (gfc_formal_arglist **head, param_sym->as->upper[i] = NULL; } param_sym->as->rank = 1; - param_sym->as->lower[0] = gfc_int_expr (1); + param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); /* The extent is unknown until we get it. The length give us the rank the incoming pointer. */ @@ -4277,7 +4281,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, #define NAMED_CHARKNDCST(a,b,c) case a : #include "iso-c-binding.def" - tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value); + tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c_interop_kinds_table[s].value); /* Initialize an integer constant expression node. */ tmp_sym->attr.flavor = FL_PARAMETER; @@ -4307,20 +4312,16 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, /* Initialize an integer constant expression node for the length of the character. */ - tmp_sym->value = gfc_get_expr (); - tmp_sym->value->expr_type = EXPR_CONSTANT; - tmp_sym->value->ts.type = BT_CHARACTER; - tmp_sym->value->ts.kind = gfc_default_character_kind; - tmp_sym->value->where = gfc_current_locus; + tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, NULL, 1); tmp_sym->value->ts.is_c_interop = 1; tmp_sym->value->ts.is_iso_c = 1; tmp_sym->value->value.character.length = 1; - tmp_sym->value->value.character.string = gfc_get_wide_string (2); tmp_sym->value->value.character.string[0] = (gfc_char_t) c_interop_kinds_table[s].value; - tmp_sym->value->value.character.string[1] = '\0'; tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - tmp_sym->ts.u.cl->length = gfc_int_expr (1); + tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); /* May not need this in both attr and ts, but do need in attr for writing module file. */ @@ -4756,8 +4757,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_NULL; + c->initializer = gfc_get_null_expr (NULL); /* Add component '$vptr'. */ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) @@ -4767,8 +4767,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; c->attr.pointer = 1; - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_NULL; } /* Since the extension field is 8 bit wide, we can only have @@ -4842,7 +4840,8 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_int_expr (derived->hash_value); + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, derived->hash_value); /* Add component '$size'. */ if (gfc_add_component (vtype, "$size", &c) == FAILURE) @@ -4854,20 +4853,21 @@ gfc_find_derived_vtab (gfc_symbol *derived) so that the correct initializer can be set later on (in gfc_conv_structure). */ c->ts.u.derived = derived; - c->initializer = gfc_int_expr (0); + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 0); /* Add component $extends. */ if (gfc_add_component (vtype, "$extends", &c) == FAILURE) return NULL; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_get_expr (); parent = gfc_get_derived_super_type (derived); if (parent) { parent_vtab = gfc_find_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; + c->initializer = gfc_get_expr (); c->initializer->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, &c->initializer->symtree); @@ -4876,7 +4876,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) { c->ts.type = BT_DERIVED; c->ts.u.derived = vtype; - c->initializer->expr_type = EXPR_NULL; + c->initializer = gfc_get_null_expr (NULL); } } vtab->ts.u.derived = vtype; -- 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/symbol.c | 373 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 361 insertions(+), 12 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 4356845e206..b19714cfca6 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4708,7 +4708,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) gfc_try gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, - gfc_array_spec **as) + gfc_array_spec **as, bool delayed_vtab) { char name[GFC_MAX_SYMBOL_LEN + 5]; gfc_symbol *fclass; @@ -4763,9 +4763,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) return FAILURE; c->ts.type = BT_DERIVED; - vtab = gfc_find_derived_vtab (ts->u.derived); - gcc_assert (vtab); - c->ts.u.derived = vtab->ts.u.derived; + if (delayed_vtab) + c->ts.u.derived = NULL; + else + { + vtab = gfc_find_derived_vtab (ts->u.derived, false); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + } c->attr.pointer = 1; } @@ -4787,10 +4792,344 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, } -/* Find the symbol for a derived type's vtab. */ +static void +add_proc_component (gfc_component *c, gfc_symbol *vtype, + gfc_symtree *st, gfc_symbol *specific, + bool is_generic, bool is_generic_specific) +{ + /* Add procedure component. */ + if (is_generic) + { + if (gfc_add_component (vtype, specific->name, &c) == FAILURE) + return; + c->ts.interface = specific; + } + else if (c && is_generic_specific) + { + c->ts.interface = st->n.tb->u.specific->n.sym; + } + else + { + c = gfc_find_component (vtype, st->name, true, true); + if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE) + return; + c->ts.interface = st->n.tb->u.specific->n.sym; + } + + if (!c->tb) + c->tb = XCNEW (gfc_typebound_proc); + *c->tb = *st->n.tb; + c->tb->ppc = 1; + c->attr.procedure = 1; + c->attr.proc_pointer = 1; + c->attr.flavor = FL_PROCEDURE; + c->attr.access = ACCESS_PRIVATE; + c->attr.external = 1; + c->attr.untyped = 1; + c->attr.if_source = IFSRC_IFBODY; + + /* A static initializer cannot be used here because the specific + function is not a constant; internal compiler error: in + output_constant, at varasm.c:4623 */ + c->initializer = NULL; +} + + +static void +add_proc_comps (gfc_component *c, gfc_symbol *vtype, + gfc_symtree *st, bool is_generic) +{ + if (c == NULL && !is_generic) + { + add_proc_component (c, vtype, st, NULL, false, false); + } + else if (is_generic && st->n.tb && vtype->components == NULL) + { + gfc_tbp_generic* g; + gfc_symbol * specific; + for (g = st->n.tb->u.generic; g; g = g->next) + { + if (!g->specific) + continue; + specific = g->specific->u.specific->n.sym; + add_proc_component (NULL, vtype, st, specific, true, false); + } + } + else if (c->attr.proc_pointer && c->tb) + { + *c->tb = *st->n.tb; + c->tb->ppc = 1; + c->ts.interface = st->n.tb->u.specific->n.sym; + } +} + +static void +add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype, + bool resolved) +{ + gfc_component *c; + gfc_symbol *generic; + char name[3 * GFC_MAX_SYMBOL_LEN + 10]; + + if (!st) + return; + + if (st->left) + add_procs_to_declared_vtab1 (st->left, vtype, resolved); + + if (st->right) + add_procs_to_declared_vtab1 (st->right, vtype, resolved); + + if (!st->n.tb) + return; + + if (!st->n.tb->is_generic && st->n.tb->u.specific) + { + c = gfc_find_component (vtype, st->name, true, true); + add_proc_comps (c, vtype, st, false); + } + else if (st->n.tb->is_generic) + { + c = gfc_find_component (vtype, st->name, true, true); + + if (c == NULL) + { + /* Add derived type component with generic name. */ + if (gfc_add_component (vtype, st->name, &c) == FAILURE) + return; + c->ts.type = BT_DERIVED; + c->attr.flavor = FL_VARIABLE; + c->attr.pointer = 1; + + /* Add a special empty derived type as a placeholder. */ + sprintf (name, "$empty"); + gfc_find_symbol (name, vtype->ns, 0, &generic); + if (generic == NULL) + { + gfc_get_symbol (name, vtype->ns, &generic); + generic->attr.flavor = FL_DERIVED; + generic->refs++; + gfc_set_sym_referenced (generic); + generic->ts.type = BT_UNKNOWN; + generic->attr.zero_comp = 1; + } + + c->ts.u.derived = generic; + } + } +} + + +static void +copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype, + bool resolved) +{ + gfc_component *c, *cmp; + gfc_symbol *vtab; + + vtab = gfc_find_derived_vtab (declared, resolved); + + for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) + { + if (gfc_find_component (vtype, cmp->name, true, true)) + continue; + + if (gfc_add_component (vtype, cmp->name, &c) == FAILURE) + return; + + if (cmp->ts.type == BT_DERIVED) + { + c->ts = cmp->ts; + c->ts.u.derived = cmp->ts.u.derived; + c->attr.flavor = FL_VARIABLE; + c->attr.pointer = 1; + c->initializer = NULL; + continue; + } + + c->tb = XCNEW (gfc_typebound_proc); + *c->tb = *cmp->tb; + c->attr.procedure = 1; + c->attr.proc_pointer = 1; + c->attr.flavor = FL_PROCEDURE; + c->attr.access = ACCESS_PRIVATE; + c->attr.external = 1; + c->ts.interface = cmp->ts.interface; + c->attr.untyped = 1; + c->attr.if_source = IFSRC_IFBODY; + c->initializer = NULL; + } +} + +static void +add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, + gfc_symbol *derived, bool resolved) +{ + gfc_symbol* super_type; + + super_type = gfc_get_derived_super_type (declared); + + if (super_type && (super_type != declared)) + add_procs_to_declared_vtab (super_type, vtype, derived, resolved); + + if (declared != derived) + copy_vtab_proc_comps (declared, vtype, resolved); + + if (declared->f2k_derived && declared->f2k_derived->tb_sym_root) + add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root, + vtype, resolved); + + if (declared->f2k_derived && declared->f2k_derived->tb_uop_root) + add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root, + vtype, resolved); +} + + +static +void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab, + const char *name) +{ + gfc_tbp_generic* g; + gfc_symbol * specific1; + gfc_symbol * specific2; + gfc_symtree *st = NULL; + gfc_component *c; + + /* Find the generic procedure using the component name. */ + st = gfc_find_typebound_proc (declared, NULL, name, true, NULL); + if (st == NULL) + st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL); + + if (st == NULL) + return; + + /* Add procedure pointer components for the specific procedures. */ + for (g = st->n.tb->u.generic; g; g = g->next) + { + if (!g->specific) + continue; + specific1 = g->specific_st->n.tb->u.specific->n.sym; + + c = vtab->ts.u.derived->components; + specific2 = NULL; + + /* Override identical specific interface. */ + if (vtab->ts.u.derived->components) + { + for (; c; c= c->next) + { + specific2 = c->ts.interface; + if (gfc_compare_interfaces (specific2, specific1, + specific1->name, 0, 0, NULL, 0)) + break; + } + } + + add_proc_component (c, vtab->ts.u.derived, g->specific_st, + NULL, false, true); + vtab->ts.u.derived->attr.zero_comp = 0; + } +} + + +static void +add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, + gfc_symbol *derived, bool resolved) +{ + gfc_component *cmp; + gfc_symtree *st = NULL; + gfc_symbol * vtab; + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + gfc_symbol* super_type; + + gcc_assert (resolved); + + for (cmp = vtype->components; cmp; cmp = cmp->next) + { + if (cmp->ts.type != BT_DERIVED) + continue; + + /* The only derived type that does not represent a generic + procedure is the pointer to the parent vtab. */ + if (cmp->ts.u.derived + && strcmp (cmp->ts.u.derived->name, "$extends") == 0) + continue; + + /* Find the generic procedure using the component name. */ + st = gfc_find_typebound_proc (declared, NULL, cmp->name, + true, NULL); + if (st == NULL) + st = gfc_find_typebound_user_op (declared, NULL, cmp->name, + true, NULL); + + /* Should be an error but we pass on it for now. */ + if (st == NULL || !st->n.tb->is_generic) + continue; + + vtab = NULL; + + /* Build a vtab and a special vtype, with only the procedure + pointer fields, to carry the pointers to the specific + procedures. Should this name ever be changed, the same + should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */ + sprintf (name, "vtab$%s$%s", vtype->name, cmp->name); + gfc_find_symbol (name, derived->ns, 0, &vtab); + if (vtab == NULL) + { + gfc_get_symbol (name, derived->ns, &vtab); + vtab->ts.type = BT_DERIVED; + vtab->attr.flavor = FL_VARIABLE; + vtab->attr.target = 1; + vtab->attr.save = SAVE_EXPLICIT; + vtab->attr.vtab = 1; + vtab->refs++; + gfc_set_sym_referenced (vtab); + sprintf (name, "%s$%s", vtype->name, cmp->name); + + gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived); + if (cmp->ts.u.derived == NULL + || (strcmp (cmp->ts.u.derived->name, "$empty") == 0)) + { + gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived); + if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return; + cmp->ts.u.derived->refs++; + gfc_set_sym_referenced (cmp->ts.u.derived); + cmp->ts.u.derived->attr.vtype = 1; + cmp->ts.u.derived->attr.zero_comp = 1; + } + vtab->ts.u.derived = cmp->ts.u.derived; + } + + /* Store this for later use in setting the pointer. */ + cmp->ts.interface = vtab; + + if (vtab->ts.u.derived->components) + continue; + + super_type = gfc_get_derived_super_type (declared); + + if (super_type && (super_type != declared)) + add_generic_specifics (super_type, vtab, cmp->name); + + add_generic_specifics (declared, vtab, cmp->name); + } +} + + +/* Find the symbol for a derived type's vtab. A vtab has the following + fields: + $hash a hash value used to identify the derived type + $size the size in bytes of the derived type + $extends a pointer to the vtable of the parent derived type + then: + procedure pointer components for the specific typebound procedures + structure pointers to reduced vtabs that contain procedure + pointers to the specific procedures. */ gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) +gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL; @@ -4815,7 +5154,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.target = 1; vtab->attr.save = SAVE_EXPLICIT; vtab->attr.vtab = 1; - vtab->attr.access = ACCESS_PRIVATE; vtab->refs++; gfc_set_sym_referenced (vtab); sprintf (name, "vtype$%s", derived->name); @@ -4832,7 +5170,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) return NULL; vtype->refs++; gfc_set_sym_referenced (vtype); - vtype->attr.access = ACCESS_PRIVATE; /* Add component '$hash'. */ if (gfc_add_component (vtype, "$hash", &c) == FAILURE) @@ -4864,13 +5201,13 @@ gfc_find_derived_vtab (gfc_symbol *derived) parent = gfc_get_derived_super_type (derived); if (parent) { - parent_vtab = gfc_find_derived_vtab (parent); + parent_vtab = gfc_find_derived_vtab (parent, resolved); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); c->initializer->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, - &c->initializer->symtree); + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, + 0, &c->initializer->symtree); } else { @@ -4878,13 +5215,25 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.u.derived = vtype; c->initializer = gfc_get_null_expr (NULL); } + + add_procs_to_declared_vtab (derived, vtype, derived, resolved); + vtype->attr.vtype = 1; } - vtab->ts.u.derived = vtype; + vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } } + /* Catch the call just before the backend declarations are built, so that + the generic procedures have been resolved and the specific procedures + have formal interfaces that can be compared. */ + if (resolved + && vtab->ts.u.derived + && vtab->ts.u.derived->backend_decl == NULL) + add_generics_to_declared_vtab (derived, vtab->ts.u.derived, + derived, resolved); + return vtab; } -- 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/symbol.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b19714cfca6..8403578b81e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4720,6 +4720,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); else if ((*as) && (*as)->rank) sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + else if (attr->pointer) + sprintf (name, ".class.%s.p", ts->u.derived->name); else if (attr->allocatable) sprintf (name, ".class.%s.a", ts->u.derived->name); else -- cgit v1.2.1 From bcc41e511c80b8b8aa549a438ffcac69481db979 Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 15 May 2010 13:52:33 +0000 Subject: 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.h (gfc_class_null_initializer): New prototype. * expr.c (gfc_class_null_initializer): New function to build a NULL initializer for CLASS pointers. * symbol.c (gfc_build_class_symbol): Modify internal naming of class containers. Remove default NULL initialization of $data component. * trans.c (gfc_allocate_array_with_status): Fix wording of an error message. * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): Use new function 'gfc_class_null_initializer'. * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar class variables. 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.dg/class_18.f03: New. * gfortran.dg/class_19.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159431 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8403578b81e..ceb45bfa6ec 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4717,15 +4717,15 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, /* Determine the name of the encapsulating type. */ if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); + sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank); else if ((*as) && (*as)->rank) - sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank); else if (attr->pointer) - sprintf (name, ".class.%s.p", ts->u.derived->name); + sprintf (name, "class$%s_p", ts->u.derived->name); else if (attr->allocatable) - sprintf (name, ".class.%s.a", ts->u.derived->name); + sprintf (name, "class$%s_a", ts->u.derived->name); else - sprintf (name, ".class.%s", ts->u.derived->name); + sprintf (name, "class$%s", ts->u.derived->name); gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); if (fclass == NULL) @@ -4759,7 +4759,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); - c->initializer = gfc_get_null_expr (NULL); + c->initializer = NULL; /* Add component '$vptr'. */ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) -- cgit v1.2.1 From b823b0c64afba9f22c659014d67843f440f886db Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 May 2010 18:45:32 +0000 Subject: 2010-05-17 Janus Weil * class.c (gfc_add_component_ref,gfc_class_null_initializer, gfc_build_class_symbol,add_proc_component,add_proc_comps, add_procs_to_declared_vtab1,copy_vtab_proc_comps, add_procs_to_declared_vtab,add_generic_specifics, add_generics_to_declared_vtab,gfc_find_derived_vtab, find_typebound_proc_uop,gfc_find_typebound_proc, gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, gfc_get_tbp_symtree): Moved here from other places. * expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to class.c. * gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab, gfc_find_typebound_proc,gfc_find_typebound_user_op, gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree, gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c. * Make-lang.in: Add class.o. * symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps, add_procs_to_declared_vtab1,copy_vtab_proc_comps, add_procs_to_declared_vtab,add_generic_specifics, add_generics_to_declared_vtab,gfc_find_derived_vtab, find_typebound_proc_uop,gfc_find_typebound_proc, gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, gfc_get_tbp_symtree): Move to class.c. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159506 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 691 --------------------------------------------------- 1 file changed, 691 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ceb45bfa6ec..b719de11044 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4699,694 +4699,3 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) else return 0; } - - -/* Build a polymorphic CLASS entity, using the symbol that comes from - build_sym. A CLASS entity is represented by an encapsulating type, - which contains the declared type as '$data' component, plus a pointer - component '$vptr' which determines the dynamic type. */ - -gfc_try -gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, - gfc_array_spec **as, bool delayed_vtab) -{ - char name[GFC_MAX_SYMBOL_LEN + 5]; - gfc_symbol *fclass; - gfc_symbol *vtab; - gfc_component *c; - - /* Determine the name of the encapsulating type. */ - if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank); - else if ((*as) && (*as)->rank) - sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank); - else if (attr->pointer) - sprintf (name, "class$%s_p", ts->u.derived->name); - else if (attr->allocatable) - sprintf (name, "class$%s_a", ts->u.derived->name); - else - sprintf (name, "class$%s", ts->u.derived->name); - - gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); - if (fclass == NULL) - { - gfc_symtree *st; - /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ts->u.derived->ns); - st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); - st->n.sym = fclass; - gfc_set_sym_referenced (fclass); - fclass->refs++; - fclass->ts.type = BT_UNKNOWN; - fclass->attr.abstract = ts->u.derived->attr.abstract; - if (ts->u.derived->f2k_derived) - fclass->f2k_derived = gfc_get_namespace (NULL, 0); - if (gfc_add_flavor (&fclass->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return FAILURE; - - /* Add component '$data'. */ - if (gfc_add_component (fclass, "$data", &c) == FAILURE) - return FAILURE; - c->ts = *ts; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->ts.u.derived = ts->u.derived; - c->attr.class_pointer = attr->pointer; - c->attr.pointer = attr->pointer || attr->dummy; - c->attr.allocatable = attr->allocatable; - c->attr.dimension = attr->dimension; - c->attr.codimension = attr->codimension; - c->attr.abstract = ts->u.derived->attr.abstract; - c->as = (*as); - c->initializer = NULL; - - /* Add component '$vptr'. */ - if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) - return FAILURE; - c->ts.type = BT_DERIVED; - if (delayed_vtab) - c->ts.u.derived = NULL; - else - { - vtab = gfc_find_derived_vtab (ts->u.derived, false); - gcc_assert (vtab); - c->ts.u.derived = vtab->ts.u.derived; - } - c->attr.pointer = 1; - } - - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - if (ts->u.derived->attr.extension == 255) - { - gfc_error ("Maximum extension level reached with type '%s' at %L", - ts->u.derived->name, &ts->u.derived->declared_at); - return FAILURE; - } - - fclass->attr.extension = ts->u.derived->attr.extension + 1; - fclass->attr.is_class = 1; - ts->u.derived = fclass; - attr->allocatable = attr->pointer = attr->dimension = 0; - (*as) = NULL; /* XXX */ - return SUCCESS; -} - - -static void -add_proc_component (gfc_component *c, gfc_symbol *vtype, - gfc_symtree *st, gfc_symbol *specific, - bool is_generic, bool is_generic_specific) -{ - /* Add procedure component. */ - if (is_generic) - { - if (gfc_add_component (vtype, specific->name, &c) == FAILURE) - return; - c->ts.interface = specific; - } - else if (c && is_generic_specific) - { - c->ts.interface = st->n.tb->u.specific->n.sym; - } - else - { - c = gfc_find_component (vtype, st->name, true, true); - if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE) - return; - c->ts.interface = st->n.tb->u.specific->n.sym; - } - - if (!c->tb) - c->tb = XCNEW (gfc_typebound_proc); - *c->tb = *st->n.tb; - c->tb->ppc = 1; - c->attr.procedure = 1; - c->attr.proc_pointer = 1; - c->attr.flavor = FL_PROCEDURE; - c->attr.access = ACCESS_PRIVATE; - c->attr.external = 1; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - - /* A static initializer cannot be used here because the specific - function is not a constant; internal compiler error: in - output_constant, at varasm.c:4623 */ - c->initializer = NULL; -} - - -static void -add_proc_comps (gfc_component *c, gfc_symbol *vtype, - gfc_symtree *st, bool is_generic) -{ - if (c == NULL && !is_generic) - { - add_proc_component (c, vtype, st, NULL, false, false); - } - else if (is_generic && st->n.tb && vtype->components == NULL) - { - gfc_tbp_generic* g; - gfc_symbol * specific; - for (g = st->n.tb->u.generic; g; g = g->next) - { - if (!g->specific) - continue; - specific = g->specific->u.specific->n.sym; - add_proc_component (NULL, vtype, st, specific, true, false); - } - } - else if (c->attr.proc_pointer && c->tb) - { - *c->tb = *st->n.tb; - c->tb->ppc = 1; - c->ts.interface = st->n.tb->u.specific->n.sym; - } -} - -static void -add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype, - bool resolved) -{ - gfc_component *c; - gfc_symbol *generic; - char name[3 * GFC_MAX_SYMBOL_LEN + 10]; - - if (!st) - return; - - if (st->left) - add_procs_to_declared_vtab1 (st->left, vtype, resolved); - - if (st->right) - add_procs_to_declared_vtab1 (st->right, vtype, resolved); - - if (!st->n.tb) - return; - - if (!st->n.tb->is_generic && st->n.tb->u.specific) - { - c = gfc_find_component (vtype, st->name, true, true); - add_proc_comps (c, vtype, st, false); - } - else if (st->n.tb->is_generic) - { - c = gfc_find_component (vtype, st->name, true, true); - - if (c == NULL) - { - /* Add derived type component with generic name. */ - if (gfc_add_component (vtype, st->name, &c) == FAILURE) - return; - c->ts.type = BT_DERIVED; - c->attr.flavor = FL_VARIABLE; - c->attr.pointer = 1; - - /* Add a special empty derived type as a placeholder. */ - sprintf (name, "$empty"); - gfc_find_symbol (name, vtype->ns, 0, &generic); - if (generic == NULL) - { - gfc_get_symbol (name, vtype->ns, &generic); - generic->attr.flavor = FL_DERIVED; - generic->refs++; - gfc_set_sym_referenced (generic); - generic->ts.type = BT_UNKNOWN; - generic->attr.zero_comp = 1; - } - - c->ts.u.derived = generic; - } - } -} - - -static void -copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype, - bool resolved) -{ - gfc_component *c, *cmp; - gfc_symbol *vtab; - - vtab = gfc_find_derived_vtab (declared, resolved); - - for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) - { - if (gfc_find_component (vtype, cmp->name, true, true)) - continue; - - if (gfc_add_component (vtype, cmp->name, &c) == FAILURE) - return; - - if (cmp->ts.type == BT_DERIVED) - { - c->ts = cmp->ts; - c->ts.u.derived = cmp->ts.u.derived; - c->attr.flavor = FL_VARIABLE; - c->attr.pointer = 1; - c->initializer = NULL; - continue; - } - - c->tb = XCNEW (gfc_typebound_proc); - *c->tb = *cmp->tb; - c->attr.procedure = 1; - c->attr.proc_pointer = 1; - c->attr.flavor = FL_PROCEDURE; - c->attr.access = ACCESS_PRIVATE; - c->attr.external = 1; - c->ts.interface = cmp->ts.interface; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - c->initializer = NULL; - } -} - -static void -add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, - gfc_symbol *derived, bool resolved) -{ - gfc_symbol* super_type; - - super_type = gfc_get_derived_super_type (declared); - - if (super_type && (super_type != declared)) - add_procs_to_declared_vtab (super_type, vtype, derived, resolved); - - if (declared != derived) - copy_vtab_proc_comps (declared, vtype, resolved); - - if (declared->f2k_derived && declared->f2k_derived->tb_sym_root) - add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root, - vtype, resolved); - - if (declared->f2k_derived && declared->f2k_derived->tb_uop_root) - add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root, - vtype, resolved); -} - - -static -void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab, - const char *name) -{ - gfc_tbp_generic* g; - gfc_symbol * specific1; - gfc_symbol * specific2; - gfc_symtree *st = NULL; - gfc_component *c; - - /* Find the generic procedure using the component name. */ - st = gfc_find_typebound_proc (declared, NULL, name, true, NULL); - if (st == NULL) - st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL); - - if (st == NULL) - return; - - /* Add procedure pointer components for the specific procedures. */ - for (g = st->n.tb->u.generic; g; g = g->next) - { - if (!g->specific) - continue; - specific1 = g->specific_st->n.tb->u.specific->n.sym; - - c = vtab->ts.u.derived->components; - specific2 = NULL; - - /* Override identical specific interface. */ - if (vtab->ts.u.derived->components) - { - for (; c; c= c->next) - { - specific2 = c->ts.interface; - if (gfc_compare_interfaces (specific2, specific1, - specific1->name, 0, 0, NULL, 0)) - break; - } - } - - add_proc_component (c, vtab->ts.u.derived, g->specific_st, - NULL, false, true); - vtab->ts.u.derived->attr.zero_comp = 0; - } -} - - -static void -add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, - gfc_symbol *derived, bool resolved) -{ - gfc_component *cmp; - gfc_symtree *st = NULL; - gfc_symbol * vtab; - char name[2 * GFC_MAX_SYMBOL_LEN + 8]; - gfc_symbol* super_type; - - gcc_assert (resolved); - - for (cmp = vtype->components; cmp; cmp = cmp->next) - { - if (cmp->ts.type != BT_DERIVED) - continue; - - /* The only derived type that does not represent a generic - procedure is the pointer to the parent vtab. */ - if (cmp->ts.u.derived - && strcmp (cmp->ts.u.derived->name, "$extends") == 0) - continue; - - /* Find the generic procedure using the component name. */ - st = gfc_find_typebound_proc (declared, NULL, cmp->name, - true, NULL); - if (st == NULL) - st = gfc_find_typebound_user_op (declared, NULL, cmp->name, - true, NULL); - - /* Should be an error but we pass on it for now. */ - if (st == NULL || !st->n.tb->is_generic) - continue; - - vtab = NULL; - - /* Build a vtab and a special vtype, with only the procedure - pointer fields, to carry the pointers to the specific - procedures. Should this name ever be changed, the same - should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */ - sprintf (name, "vtab$%s$%s", vtype->name, cmp->name); - gfc_find_symbol (name, derived->ns, 0, &vtab); - if (vtab == NULL) - { - gfc_get_symbol (name, derived->ns, &vtab); - vtab->ts.type = BT_DERIVED; - vtab->attr.flavor = FL_VARIABLE; - vtab->attr.target = 1; - vtab->attr.save = SAVE_EXPLICIT; - vtab->attr.vtab = 1; - vtab->refs++; - gfc_set_sym_referenced (vtab); - sprintf (name, "%s$%s", vtype->name, cmp->name); - - gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived); - if (cmp->ts.u.derived == NULL - || (strcmp (cmp->ts.u.derived->name, "$empty") == 0)) - { - gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived); - if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return; - cmp->ts.u.derived->refs++; - gfc_set_sym_referenced (cmp->ts.u.derived); - cmp->ts.u.derived->attr.vtype = 1; - cmp->ts.u.derived->attr.zero_comp = 1; - } - vtab->ts.u.derived = cmp->ts.u.derived; - } - - /* Store this for later use in setting the pointer. */ - cmp->ts.interface = vtab; - - if (vtab->ts.u.derived->components) - continue; - - super_type = gfc_get_derived_super_type (declared); - - if (super_type && (super_type != declared)) - add_generic_specifics (super_type, vtab, cmp->name); - - add_generic_specifics (declared, vtab, cmp->name); - } -} - - -/* Find the symbol for a derived type's vtab. A vtab has the following - fields: - $hash a hash value used to identify the derived type - $size the size in bytes of the derived type - $extends a pointer to the vtable of the parent derived type - then: - procedure pointer components for the specific typebound procedures - structure pointers to reduced vtabs that contain procedure - pointers to the specific procedures. */ - -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) -{ - gfc_namespace *ns; - gfc_symbol *vtab = NULL, *vtype = NULL; - char name[2 * GFC_MAX_SYMBOL_LEN + 8]; - - ns = gfc_current_ns; - - for (; ns; ns = ns->parent) - if (!ns->parent) - break; - - if (ns) - { - sprintf (name, "vtab$%s", derived->name); - gfc_find_symbol (name, ns, 0, &vtab); - - if (vtab == NULL) - { - gfc_get_symbol (name, ns, &vtab); - vtab->ts.type = BT_DERIVED; - vtab->attr.flavor = FL_VARIABLE; - vtab->attr.target = 1; - vtab->attr.save = SAVE_EXPLICIT; - vtab->attr.vtab = 1; - vtab->refs++; - gfc_set_sym_referenced (vtab); - sprintf (name, "vtype$%s", derived->name); - - gfc_find_symbol (name, ns, 0, &vtype); - if (vtype == NULL) - { - gfc_component *c; - gfc_symbol *parent = NULL, *parent_vtab = NULL; - - gfc_get_symbol (name, ns, &vtype); - if (gfc_add_flavor (&vtype->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return NULL; - vtype->refs++; - gfc_set_sym_referenced (vtype); - - /* Add component '$hash'. */ - if (gfc_add_component (vtype, "$hash", &c) == FAILURE) - return NULL; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, - NULL, derived->hash_value); - - /* Add component '$size'. */ - if (gfc_add_component (vtype, "$size", &c) == FAILURE) - return NULL; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - /* Remember the derived type in ts.u.derived, - so that the correct initializer can be set later on - (in gfc_conv_structure). */ - c->ts.u.derived = derived; - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 0); - - /* Add component $extends. */ - if (gfc_add_component (vtype, "$extends", &c) == FAILURE) - return NULL; - c->attr.pointer = 1; - c->attr.access = ACCESS_PRIVATE; - parent = gfc_get_derived_super_type (derived); - if (parent) - { - parent_vtab = gfc_find_derived_vtab (parent, resolved); - c->ts.type = BT_DERIVED; - c->ts.u.derived = parent_vtab->ts.u.derived; - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, - 0, &c->initializer->symtree); - } - else - { - c->ts.type = BT_DERIVED; - c->ts.u.derived = vtype; - c->initializer = gfc_get_null_expr (NULL); - } - - add_procs_to_declared_vtab (derived, vtype, derived, resolved); - vtype->attr.vtype = 1; - } - - vtab->ts.u.derived = vtype; - vtab->value = gfc_default_initializer (&vtab->ts); - } - } - - /* Catch the call just before the backend declarations are built, so that - the generic procedures have been resolved and the specific procedures - have formal interfaces that can be compared. */ - if (resolved - && vtab->ts.u.derived - && vtab->ts.u.derived->backend_decl == NULL) - add_generics_to_declared_vtab (derived, vtab->ts.u.derived, - derived, resolved); - - return vtab; -} - - -/* General worker function to find either a type-bound procedure or a - type-bound user operator. */ - -static gfc_symtree* -find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, bool uop, - locus* where) -{ - gfc_symtree* res; - gfc_symtree* root; - - /* Set correct symbol-root. */ - gcc_assert (derived->f2k_derived); - root = (uop ? derived->f2k_derived->tb_uop_root - : derived->f2k_derived->tb_sym_root); - - /* Set default to failure. */ - if (t) - *t = FAILURE; - - /* Try to find it in the current type's namespace. */ - res = gfc_find_symtree (root, name); - if (res && res->n.tb && !res->n.tb->error) - { - /* We found one. */ - if (t) - *t = SUCCESS; - - if (!noaccess && derived->attr.use_assoc - && res->n.tb->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", - name, derived->name, where); - if (t) - *t = FAILURE; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return find_typebound_proc_uop (super_type, t, name, - noaccess, uop, where); - } - - /* Nothing found. */ - return NULL; -} - - -/* Find a type-bound procedure or user operator by name for a derived-type - (looking recursively through the super-types). */ - -gfc_symtree* -gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, false, where); -} - -gfc_symtree* -gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, true, where); -} - - -/* Find a type-bound intrinsic operator looking recursively through the - super-type hierarchy. */ - -gfc_typebound_proc* -gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, - gfc_intrinsic_op op, bool noaccess, - locus* where) -{ - gfc_typebound_proc* res; - - /* Set default to failure. */ - if (t) - *t = FAILURE; - - /* Try to find it in the current type's namespace. */ - if (derived->f2k_derived) - res = derived->f2k_derived->tb_op[op]; - else - res = NULL; - - /* Check access. */ - if (res && !res->error) - { - /* We found one. */ - if (t) - *t = SUCCESS; - - if (!noaccess && derived->attr.use_assoc - && res->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", - gfc_op2string (op), derived->name, where); - if (t) - *t = FAILURE; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return gfc_find_typebound_intrinsic_op (super_type, t, op, - noaccess, where); - } - - /* Nothing found. */ - return NULL; -} - - -/* Get a typebound-procedure symtree or create and insert it if not yet - present. This is like a very simplified version of gfc_get_sym_tree for - tbp-symtrees rather than regular ones. */ - -gfc_symtree* -gfc_get_tbp_symtree (gfc_symtree **root, const char *name) -{ - gfc_symtree *result; - - result = gfc_find_symtree (*root, name); - if (!result) - { - result = gfc_new_symtree (root, name); - gcc_assert (result); - result->n.tb = NULL; - } - - return result; -} -- 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/symbol.c | 26 ++++---------------------- 1 file changed, 4 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b719de11044..b436de5e2af 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4661,8 +4661,6 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - gfc_component *cmp1, *cmp2; - bool is_class1 = (ts1->type == BT_CLASS); bool is_class2 = (ts2->type == BT_CLASS); bool is_derived1 = (ts1->type == BT_DERIVED); @@ -4674,28 +4672,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if (is_derived1 && is_derived2) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - cmp1 = cmp2 = NULL; - - if (is_class1) - { - cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false); - if (cmp1 == NULL) - return 0; - } - - if (is_class2) - { - cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false); - if (cmp2 == NULL) - return 0; - } - if (is_class1 && is_derived2) - return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived); - + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived); else if (is_class1 && is_class2) - return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived); - + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived->components->ts.u.derived); else return 0; } -- 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/symbol.c | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b436de5e2af..adae49f1606 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -567,7 +567,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) } conf (is_protected, intrinsic) - conf (is_protected, external) conf (is_protected, in_common) conf (asynchronous, intrinsic) @@ -587,7 +586,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, dimension) conf (procedure, codimension) conf (procedure, intrinsic) - conf (procedure, is_protected) conf (procedure, target) conf (procedure, value) conf (procedure, volatile_) -- cgit v1.2.1 From c8f6f57ca00b8b595b5861ef5cbded593a28359f Mon Sep 17 00:00:00 2001 From: kargl Date: Wed, 9 Jun 2010 18:32:20 +0000 Subject: 2010-06-09 Steven G. Kargl * gfortran.dg/data_namelist_conflict.f90: New test. 2010-06-09 Steven G. Kargl * fortran/symbol.c (check_conflict): Remove an invalid conflict check. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160503 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 1 - 1 file changed, 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index adae49f1606..07802e8349a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -545,7 +545,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (data, function); conf (data, result); conf (data, allocatable); - conf (data, use_assoc); conf (value, pointer) conf (value, allocatable) -- 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/symbol.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 07802e8349a..049e4a73528 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2512,6 +2512,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) /* Clear the ptrs we may need. */ p->common_block = NULL; p->f2k_derived = NULL; + p->assoc = NULL; return p; } -- cgit v1.2.1 From 4a12b9ba04a45f09308052f1b1fcd57c98a1f259 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 16 Jun 2010 12:54:54 +0000 Subject: 2010-06-16 Janus Weil PR fortran/44549 * gfortran.h (gfc_get_typebound_proc): Modified Prototype. * decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc structure to each procedure in a procedure list. * module.c (mio_typebound_proc): Add NULL argument to 'gfc_get_typebound_proc'. * symbol.c (gfc_get_typebound_proc): Add a new argument, which is used to initialize the new structure. 2010-06-16 Janus Weil PR fortran/44549 * gfortran.dg/typebound_proc_16.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160834 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 049e4a73528..11a039576a1 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4591,12 +4591,14 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, list and marked `error' until symbols are committed. */ gfc_typebound_proc* -gfc_get_typebound_proc (void) +gfc_get_typebound_proc (gfc_typebound_proc *tb0) { gfc_typebound_proc *result; tentative_tbp *list_node; result = XCNEW (gfc_typebound_proc); + if (tb0) + *result = *tb0; result->error = 1; list_node = XCNEW (tentative_tbp); -- 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/symbol.c | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 11a039576a1..df6ada963c3 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -372,7 +372,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -518,6 +519,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -529,6 +531,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, contiguous); conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); @@ -613,6 +616,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dummy); conf2 (volatile_); conf2 (asynchronous); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -720,6 +724,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (entry); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -927,6 +932,18 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) } +gfc_try +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + attr->contiguous = 1; + return check_conflict (attr, name, where); +} + + gfc_try gfc_add_external (symbol_attribute *attr, locus *where) { @@ -1715,6 +1732,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) goto fail; + if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) -- cgit v1.2.1 From ec1eb337c3957b0af94ee75f18fe034e57d84b83 Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 22 Jul 2010 11:35:09 +0000 Subject: 2010-07-22 Tobias Burnus PR fortran/45019 * dependency.c (gfc_check_dependency): Add argument alising * check. * symbol.c (gfc_symbols_could_alias): Add argument alising * check. 2010-07-22 Tobias Burnus PR fortran/45019 * gfortran.dg/aliasing_dummy_5.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162410 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index df6ada963c3..c12ea23a05e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2811,6 +2811,17 @@ gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym) if (lsym->attr.allocatable && rsym->attr.pointer) return 1; + /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 + and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already + checked above. */ + if (lsym->attr.target && rsym->attr.target + && ((lsym->attr.dummy && !lsym->attr.contiguous + && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) + || (rsym->attr.dummy && !rsym->attr.contiguous + && (!rsym->attr.dimension + || rsym->as->type == AS_ASSUMED_SHAPE)))) + return 1; + return 0; } -- cgit v1.2.1 From 98f8bf075936982049c512465c37c6283cf85693 Mon Sep 17 00:00:00 2001 From: domob Date: Fri, 23 Jul 2010 09:53:45 +0000 Subject: 2010-07-23 Daniel Kraft PR fortran/44709 * gfortran.h (gfc_find_symtree_in_proc): New method. * symbol.c (gfc_find_symtree_in_proc): New method. * match.c (match_exit_cycle): Look for loop name also in parent namespaces within current procedure. 2010-07-23 Daniel Kraft PR fortran/44709 * gfortran.dg/exit_1.f08: New test. * gfortran.dg/exit_2.f08: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162450 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/symbol.c | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) (limited to 'gcc/fortran/symbol.c') diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c12ea23a05e..18f7b253a28 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2565,6 +2565,27 @@ select_type_insert_tmp (gfc_symtree **st) } +/* Look for a symtree in the current procedure -- that is, go up to + parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ + +gfc_symtree* +gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) +{ + while (ns) + { + gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); + if (st) + return st; + + if (!ns->construct_entities) + break; + ns = ns->parent; + } + + return NULL; +} + + /* Search for a symtree starting in the current namespace, resorting to any parent namespaces if requested by a nonzero parent_flag. Returns nonzero if the name is ambiguous. */ -- cgit v1.2.1