X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-types.c;h=dca19ce90b65af49a4705e23a6e636a2ebc588da;hp=92373e1b1a2d65eb4602711a676270bd537a865e;hb=09f0274a41880a77d1827c16faa5e9e233b68510;hpb=7ea64434b40d07d43f4aa6cafac4684487e69304 diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 92373e1b1a2..dca19ce90b6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1,5 +1,6 @@ /* Backend support for Fortran 95 basic types and derived types. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -53,12 +54,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 +67,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 +866,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 @@ -1000,8 +1001,8 @@ gfc_typenode_for_spec (gfc_typespec * spec) C_FUNPTR to simple variables that get translated to (void *). */ if (spec->f90_type == BT_VOID) { - if (spec->derived - && spec->derived->intmod_sym_id == ISOCBINDING_PTR) + if (spec->u.derived + && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) basetype = ptr_type_node; else basetype = pfunc_type_node; @@ -1023,21 +1024,22 @@ gfc_typenode_for_spec (gfc_typespec * spec) break; case BT_CHARACTER: - basetype = gfc_get_character_type (spec->kind, spec->cl); + basetype = gfc_get_character_type (spec->kind, spec->u.cl); break; case BT_DERIVED: - basetype = gfc_get_derived_type (spec->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 type and kind to fit a (void *) and the basetype returned was a ptr_type_node. We need to pass up this new information to the symbol that was declared of type C_PTR or C_FUNPTR. */ - if (spec->derived->attr.is_iso_c) + if (spec->u.derived->attr.is_iso_c) { - spec->type = spec->derived->ts.type; - spec->kind = spec->derived->ts.kind; - spec->f90_type = spec->derived->ts.f90_type; + spec->type = spec->u.derived->ts.type; + spec->kind = spec->u.derived->ts.kind; + spec->f90_type = spec->u.derived->ts.f90_type; } break; case BT_VOID: @@ -1046,8 +1048,8 @@ gfc_typenode_for_spec (gfc_typespec * spec) basetype = ptr_type_node; if (spec->f90_type == BT_VOID) { - if (spec->derived - && spec->derived->intmod_sym_id == ISOCBINDING_PTR) + if (spec->u.derived + && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) basetype = ptr_type_node; else basetype = pfunc_type_node; @@ -1192,7 +1194,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 +1204,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 +1222,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, as->corank, lbound, + ubound, 0, akind, restricted); } /* Returns the struct descriptor_dimension type. */ @@ -1365,7 +1368,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 +1478,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 +1527,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,24 +1538,26 @@ 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, int codimen, bool restricted) { tree fat_type, fieldlist, decl, arraytype; - char name[16 + GFC_RANK_DIGITS + 1]; + char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; + int idx = 2 * (codimen + 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]; + gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); + if (gfc_array_descriptor_base[idx]) + return gfc_array_descriptor_base[idx]; /* Build the type node. */ fat_type = make_node (RECORD_TYPE); - sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen); + sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); TYPE_NAME (fat_type) = get_identifier (name); /* 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; @@ -1571,7 +1583,7 @@ gfc_get_array_descriptor_base (int dimen) build_array_type (gfc_get_desc_dim_type (), build_range_type (gfc_array_index_type, gfc_index_zero_node, - gfc_rank_cst[dimen - 1])); + gfc_rank_cst[codimen + dimen - 1])); decl = build_decl (input_location, FIELD_DECL, get_identifier ("dim"), arraytype); @@ -1585,24 +1597,27 @@ 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; } /* Build an array (descriptor) type with given bounds. */ tree -gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, +gfc_get_array_type_bounds (tree etype, int dimen, int codimen, 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]; + char name[8 + 2*GFC_RANK_DIGITS + 1 + 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, codimen, 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, codimen, false); TYPE_CANONICAL (fat_type) = base_type; TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); @@ -1613,7 +1628,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, type_name = IDENTIFIER_POINTER (tmp); else type_name = "unknown"; - sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, + sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen, GFC_MAX_SYMBOL_LEN, type_name); TYPE_NAME (fat_type) = get_identifier (name); @@ -1684,6 +1699,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 +1740,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 +1775,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)) @@ -1765,13 +1785,17 @@ gfc_sym_type (gfc_symbol * sym) base type. */ if (sym->ts.type != BT_CHARACTER || !(sym->attr.dummy || sym->attr.function) - || sym->ts.cl->backend_decl) + || sym->ts.u.cl->backend_decl) { type = gfc_get_nodesc_array_type (type, sym->as, byref ? PACKED_FULL - : PACKED_STATIC); + : PACKED_STATIC, + restricted); byref = 0; } + + if (sym->attr.cray_pointee) + GFC_POINTER_TYPE_P (type) = 1; } else { @@ -1780,14 +1804,14 @@ 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 { if (sym->attr.allocatable || sym->attr.pointer) type = gfc_build_pointer_type (sym, type); - if (sym->attr.pointer) + if (sym->attr.pointer || sym->attr.cray_pointee) GFC_POINTER_TYPE_P (type) = 1; } @@ -1801,7 +1825,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); @@ -1879,10 +1907,10 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, to_cm->backend_decl = from_cm->backend_decl; if ((!from_cm->attr.pointer || from_gsym) && from_cm->ts.type == BT_DERIVED) - gfc_get_derived_type (to_cm->ts.derived); + gfc_get_derived_type (to_cm->ts.u.derived); else if (from_cm->ts.type == BT_CHARACTER) - to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl; + to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl; } return 1; @@ -1895,16 +1923,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.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 +1943,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 +2041,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,21 +2066,21 @@ 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) - || c->ts.derived->backend_decl == NULL) - c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived); + || c->ts.u.derived->backend_decl == NULL) + c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived); - if (c->ts.derived && c->ts.derived->attr.is_iso_c) + if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c) { /* Need to copy the modified ts from the derived type. The typespec was modified because C_PTR/C_FUNPTR are translated into (void *) from derived types. */ - c->ts.type = c->ts.derived->ts.type; - c->ts.kind = c->ts.derived->ts.kind; - c->ts.f90_type = c->ts.derived->ts.f90_type; + c->ts.type = c->ts.u.derived->ts.type; + c->ts.kind = c->ts.u.derived->ts.kind; + c->ts.f90_type = c->ts.u.derived->ts.f90_type; if (c->initializer) { c->initializer->ts.type = c->ts.type; @@ -2069,15 +2101,15 @@ 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) - field_type = c->ts.derived->backend_decl; + else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + field_type = c->ts.u.derived->backend_decl; else { if (c->ts.type == BT_CHARACTER) { /* Evaluate the string length. */ - gfc_conv_const_charlen (c->ts.cl); - gcc_assert (c->ts.cl->backend_decl); + gfc_conv_const_charlen (c->ts.u.cl); + gcc_assert (c->ts.u.cl->backend_decl); } field_type = gfc_typenode_for_spec (&c->ts); @@ -2096,18 +2128,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) @@ -2123,7 +2158,8 @@ gfc_get_derived_type (gfc_symbol * derived) /* Now we have the final fieldlist. Record it, then lay out the derived type, including the fields. */ TYPE_FIELDS (typenode) = fieldlist; - TYPE_CANONICAL (typenode) = canonical; + if (canonical) + TYPE_CANONICAL (typenode) = canonical; gfc_finish_type (typenode); gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at); @@ -2260,7 +2296,7 @@ gfc_get_function_type (gfc_symbol * sym) arg = sym; if (arg->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (arg->ts.cl); + gfc_conv_const_charlen (arg->ts.u.cl); /* Some functions we use an extra parameter for the return value. */ if (gfc_return_by_reference (sym)) @@ -2285,7 +2321,7 @@ gfc_get_function_type (gfc_symbol * sym) /* Evaluate constant character lengths here so that they can be included in the type. */ if (arg->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (arg->ts.cl); + gfc_conv_const_charlen (arg->ts.u.cl); if (arg->attr.flavor == FL_PROCEDURE) { @@ -2456,7 +2492,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)) @@ -2512,7 +2548,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);