X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-types.c;h=ebe4c2f832bfce5023857d034990dde19bb4586c;hb=452695a8da676319b005b0fdfafc623139ea2f83;hp=8cc63c260377f197dd1db8e9b11782ccbffe7f67;hpb=eeebe20ba63ca092de5e2d4575b5765dd88a7ce6;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 8cc63c26037..ebe4c2f832b 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -53,12 +53,11 @@ along with GCC; see the file COPYING3. If not see /* array of structs so we don't have to worry about xmalloc or free */ CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; -static tree gfc_get_derived_type (gfc_symbol * derived); - tree gfc_array_index_type; tree gfc_array_range_type; tree gfc_character1_type_node; tree pvoid_type_node; +tree prvoid_type_node; tree ppvoid_type_node; tree pchar_type_node; tree pfunc_type_node; @@ -67,7 +66,7 @@ tree gfc_charlen_type_node; static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; -static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS]; +static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS]; /* Arrays for all integral and real kinds. We'll fill this in at runtime after the target has a chance to process command-line options. */ @@ -866,6 +865,7 @@ gfc_init_types (void) #undef PUSH_TYPE pvoid_type_node = build_pointer_type (void_type_node); + prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT); ppvoid_type_node = build_pointer_type (pvoid_type_node); pchar_type_node = build_pointer_type (gfc_character1_type_node); pfunc_type_node @@ -1027,6 +1027,7 @@ gfc_typenode_for_spec (gfc_typespec * spec) break; case BT_DERIVED: + case BT_CLASS: basetype = gfc_get_derived_type (spec->u.derived); /* If we're dealing with either C_PTR or C_FUNPTR, we modified the @@ -1192,7 +1193,7 @@ gfc_is_nodesc_array (gfc_symbol * sym) if (sym->attr.result || sym->attr.function) return 0; - gcc_assert (sym->as->type == AS_EXPLICIT); + gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed); return 1; } @@ -1202,7 +1203,7 @@ gfc_is_nodesc_array (gfc_symbol * sym) static tree gfc_build_array_type (tree type, gfc_array_spec * as, - enum gfc_array_kind akind) + enum gfc_array_kind akind, bool restricted) { tree lbound[GFC_MAX_DIMENSIONS]; tree ubound[GFC_MAX_DIMENSIONS]; @@ -1220,7 +1221,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as, if (as->type == AS_ASSUMED_SHAPE) akind = GFC_ARRAY_ASSUMED_SHAPE; - return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind); + return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind, + restricted); } /* Returns the struct descriptor_dimension type. */ @@ -1365,7 +1367,8 @@ gfc_get_dtype (tree type) to the value of PACKED. */ tree -gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed) +gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, + bool restricted) { tree range; tree type; @@ -1474,6 +1477,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed) /* TODO: use main type if it is unbounded. */ GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = build_pointer_type (build_array_type (etype, range)); + if (restricted) + GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = + build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), + TYPE_QUAL_RESTRICT); if (known_stride) { @@ -1519,6 +1526,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed) /* For dummy arrays and automatic (heap allocated) arrays we want a pointer to the array. */ type = build_pointer_type (type); + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); GFC_ARRAY_TYPE_P (type) = 1; TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); } @@ -1528,14 +1537,15 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed) /* Return or create the base type for an array descriptor. */ static tree -gfc_get_array_descriptor_base (int dimen) +gfc_get_array_descriptor_base (int dimen, bool restricted) { tree fat_type, fieldlist, decl, arraytype; char name[16 + GFC_RANK_DIGITS + 1]; + int idx = 2 * (dimen - 1) + restricted; gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS); - if (gfc_array_descriptor_base[dimen - 1]) - return gfc_array_descriptor_base[dimen - 1]; + if (gfc_array_descriptor_base[idx]) + return gfc_array_descriptor_base[idx]; /* Build the type node. */ fat_type = make_node (RECORD_TYPE); @@ -1545,7 +1555,8 @@ gfc_get_array_descriptor_base (int dimen) /* Add the data member as the first element of the descriptor. */ decl = build_decl (input_location, - FIELD_DECL, get_identifier ("data"), ptr_type_node); + FIELD_DECL, get_identifier ("data"), + restricted ? prvoid_type_node : ptr_type_node); DECL_CONTEXT (decl) = fat_type; fieldlist = decl; @@ -1585,7 +1596,7 @@ gfc_get_array_descriptor_base (int dimen) gfc_finish_type (fat_type); TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1; - gfc_array_descriptor_base[dimen - 1] = fat_type; + gfc_array_descriptor_base[idx] = fat_type; return fat_type; } @@ -1594,15 +1605,18 @@ gfc_get_array_descriptor_base (int dimen) tree gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, tree * ubound, int packed, - enum gfc_array_kind akind) + enum gfc_array_kind akind, bool restricted) { char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN]; tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype; const char *type_name; int n; - base_type = gfc_get_array_descriptor_base (dimen); + base_type = gfc_get_array_descriptor_base (dimen, restricted); fat_type = build_distinct_type_copy (base_type); + /* Make sure that nontarget and target array type have the same canonical + type (and same stub decl for debug info). */ + base_type = gfc_get_array_descriptor_base (dimen, false); TYPE_CANONICAL (fat_type) = base_type; TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); @@ -1684,6 +1698,8 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, rtype = gfc_array_range_type; arraytype = build_array_type (etype, rtype); arraytype = build_pointer_type (arraytype); + if (restricted) + arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; /* This will generate the base declarations we need to emit debug @@ -1723,6 +1739,7 @@ gfc_sym_type (gfc_symbol * sym) { tree type; int byref; + bool restricted; /* Procedure Pointers inside COMMON blocks. */ if (sym->attr.proc_pointer && sym->attr.in_common) @@ -1757,6 +1774,8 @@ gfc_sym_type (gfc_symbol * sym) else byref = 0; + restricted = !sym->attr.target && !sym->attr.pointer + && !sym->attr.proc_pointer && !sym->attr.cray_pointee; if (sym->attr.dimension) { if (gfc_is_nodesc_array (sym)) @@ -1769,7 +1788,8 @@ gfc_sym_type (gfc_symbol * sym) { type = gfc_get_nodesc_array_type (type, sym->as, byref ? PACKED_FULL - : PACKED_STATIC); + : PACKED_STATIC, + restricted); byref = 0; } } @@ -1780,7 +1800,7 @@ gfc_sym_type (gfc_symbol * sym) akind = GFC_ARRAY_POINTER; else if (sym->attr.allocatable) akind = GFC_ARRAY_ALLOCATABLE; - type = gfc_build_array_type (type, sym->as, akind); + type = gfc_build_array_type (type, sym->as, akind, restricted); } } else @@ -1801,7 +1821,11 @@ gfc_sym_type (gfc_symbol * sym) if (sym->attr.optional || sym->ns->proc_name->attr.entry_master) type = build_pointer_type (type); else - type = build_reference_type (type); + { + type = build_reference_type (type); + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); + } } return (type); @@ -1895,16 +1919,17 @@ tree gfc_get_ppc_type (gfc_component* c) { tree t; - if (c->attr.function && !c->attr.dimension) - { - if (c->ts.type == BT_DERIVED) - t = c->ts.u.derived->backend_decl; - else - t = gfc_typenode_for_spec (&c->ts); - } + + /* Explicit interface. */ + if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface) + return build_pointer_type (gfc_get_function_type (c->ts.interface)); + + /* Implicit interface (only return value may be known). */ + if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER) + t = gfc_typenode_for_spec (&c->ts); else t = void_type_node; - /* TODO: Build argument list. */ + return build_pointer_type (build_function_type (t, NULL_TREE)); } @@ -1914,7 +1939,7 @@ gfc_get_ppc_type (gfc_component* c) at the same time. If an equal derived type has been built in a parent namespace, this is used. */ -static tree +tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; @@ -2012,8 +2037,11 @@ gfc_get_derived_type (gfc_symbol * derived) components' backend_decl may have not been built. */ if (derived->backend_decl) { - /* Its components' backend_decl have been built. */ - if (TYPE_FIELDS (derived->backend_decl)) + /* Its components' backend_decl have been built or we are + seeing recursion through the formal arglist of a procedure + pointer component. */ + if (TYPE_FIELDS (derived->backend_decl) + || derived->attr.proc_pointer_comp) return derived->backend_decl; else typenode = derived->backend_decl; @@ -2034,7 +2062,7 @@ gfc_get_derived_type (gfc_symbol * derived) will be built and so we can return the type. */ for (c = derived->components; c; c = c->next) { - if (c->ts.type != BT_DERIVED) + if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) continue; if ((!c->attr.pointer && !c->attr.proc_pointer) @@ -2069,7 +2097,7 @@ gfc_get_derived_type (gfc_symbol * derived) { if (c->attr.proc_pointer) field_type = gfc_get_ppc_type (c); - else if (c->ts.type == BT_DERIVED) + else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) field_type = c->ts.u.derived->backend_decl; else { @@ -2096,18 +2124,21 @@ gfc_get_derived_type (gfc_symbol * derived) akind = GFC_ARRAY_ALLOCATABLE; /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ - field_type = gfc_build_array_type (field_type, c->as, akind); + field_type = gfc_build_array_type (field_type, c->as, akind, + !c->attr.target + && !c->attr.pointer); } else field_type = gfc_get_nodesc_array_type (field_type, c->as, - PACKED_STATIC); + PACKED_STATIC, + !c->attr.target); } - else if (c->attr.pointer) + else if ((c->attr.pointer || c->attr.allocatable) + && !c->attr.proc_pointer) field_type = build_pointer_type (field_type); field = gfc_add_field_to_struct (&fieldlist, typenode, - get_identifier (c->name), - field_type); + get_identifier (c->name), field_type); if (c->loc.lb) gfc_set_decl_location (field, &c->loc); else if (derived->declared_at.lb) @@ -2457,7 +2488,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) int rank, dim; bool indirect = false; tree etype, ptype, field, t, base_decl; - tree data_off, offset_off, dim_off, dim_size, elem_size; + tree data_off, dim_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; if (! GFC_DESCRIPTOR_TYPE_P (type)) @@ -2513,7 +2544,6 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); data_off = byte_position (field); field = TREE_CHAIN (field); - offset_off = byte_position (field); field = TREE_CHAIN (field); field = TREE_CHAIN (field); dim_off = byte_position (field);