ALL IN ONE DUMP This patch is a simple git diff of gcc/fortran; it contains all the other garbage and previously posted patches, including the scalar support (burried in trans-expr.c, trans-types.c). Plus some CLASS related bug fixes (class.c, check.c, trans-expr.c, interface.c) Most stuff is working, but not the following; * Assigning back after the function call scalar = (class.)array.data; and class._data = (class.)array.data The code is there, but se->post doesn't seem to produce the code. FIXME: THis should only be added for attr.(pointer|allocatable) See test cases below. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b36d517..e986299 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -389,9 +389,11 @@ match_array_element_spec (gfc_array_spec *as) { gfc_expr **upper, **lower; match m; + int rank; - lower = &as->lower[as->rank + as->corank - 1]; - upper = &as->upper[as->rank + as->corank - 1]; + rank = as->rank == -1 ? 0 : as->rank; + lower = &as->lower[rank + as->corank - 1]; + upper = &as->upper[rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { @@ -457,6 +459,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) goto coarray; } + if (gfc_match (" .. )") == MATCH_YES) + { + as->type = AS_ASSUMED_RANK; + as->rank = -1; + + if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array " + "at %C") == FAILURE) + goto cleanup; + + if (!match_codim) + goto done; + goto coarray; + } + for (;;) { as->rank++; @@ -535,6 +551,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (')') == MATCH_YES) @@ -641,6 +660,9 @@ coarray: case AS_ASSUMED_SIZE: gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (']') == MATCH_YES) @@ -1959,6 +1981,9 @@ spec_size (gfc_array_spec *as, mpz_t *result) mpz_t size; int d; + if (as->type == AS_ASSUMED_RANK) + return FAILURE; + mpz_init_set_ui (*result, 1); for (d = 0; d < as->rank; d++) @@ -2115,6 +2140,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) if (array->ts.type == BT_CLASS) return FAILURE; + if (array->rank == -1) + return FAILURE; + if (dimen < 0 || array == NULL || dimen > array->rank - 1) gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 7d505d5..b0c4b28 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) else rank = array->rank; + /* Assumed-rank array. */ + if (rank == -1) + rank = GFC_MAX_DIMENSIONS; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index c71aa4a..23b3657 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -219,7 +219,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name) void gfc_add_class_array_ref (gfc_expr *e) { - int rank = CLASS_DATA (e)->as->rank; + int rank = CLASS_DATA (e)->as->rank; gfc_array_spec *as = CLASS_DATA (e)->as; gfc_ref *ref = NULL; gfc_add_component_ref (e, "_data"); @@ -497,6 +497,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; + int rank; if (as && *as && (*as)->type == AS_ASSUMED_SIZE) { @@ -517,11 +518,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, return SUCCESS; /* Determine the name of the encapsulating type. */ + rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) - sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank); + else if ((*as) && attr->pointer) + sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank); else if ((*as)) - sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank); else if (attr->pointer) sprintf (name, "__class_%s_p", tname); else if (attr->allocatable) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 26b5059..4c360bf 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -593,7 +593,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) { int i; - if (to->rank == 0 && from->rank > 0) + if (to->rank == 0 && from->rank != 0) { to->rank = from->rank; to->type = from->type; @@ -621,20 +621,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) } else if (to->corank == 0 && from->corank > 0) { + int rank; + to->corank = from->corank; to->cotype = from->cotype; + rank = to->rank == -1 ? 0 : to->rank; + for (i = 0; i < from->corank; i++) { if (copy) { - to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]); - to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]); + to->lower[rank + i] = gfc_copy_expr (from->lower[i]); + to->upper[rank + i] = gfc_copy_expr (from->upper[i]); } else { - to->lower[to->rank + i] = from->lower[i]; - to->upper[to->rank + i] = from->upper[i]; + to->lower[rank + i] = from->lower[i]; + to->upper[rank + i] = from->upper[i]; } } } diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7f1d28f..d94d9d3 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -165,7 +165,7 @@ show_array_spec (gfc_array_spec *as) fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - if (as->rank + as->corank > 0) + if (as->rank + as->corank > 0 || as->rank == -1) { switch (as->type) { @@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as) case AS_DEFERRED: c = "AS_DEFERRED"; break; case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; + case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; default: gfc_internal_error ("show_array_spec(): Unhandled array shape " "type."); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 0b38cac..29cfa5e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4441,7 +4441,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict) || (!part_ref && !sym->attr.contiguous && (sym->attr.pointer - || sym->as->type == AS_ASSUMED_SHAPE)))) + || sym->as->type == AS_ASSUMED_RANK + || sym->as->type == AS_ASSUMED_SHAPE)))) return false; if (!ar || ar->type == AR_FULL) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index caa23bd..d0f58ac 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -132,7 +132,8 @@ expr_t; /* Array types. */ typedef enum { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED, - AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN + AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK, + AS_UNKNOWN } array_type; @@ -573,7 +574,8 @@ typedef enum { GFC_FCOARRAY_NONE = 0, GFC_FCOARRAY_SINGLE, - GFC_FCOARRAY_LIB + GFC_FCOARRAY_LIB, + GFC_FCOARRAY_OPENMP } gfc_fcoarray; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 34e1ad7..541b1e9 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) r1 = (s1->as != NULL) ? s1->as->rank : 0; r2 = (s2->as != NULL) ? s2->as->rank : 0; - if (r1 != r2) + if (r1 != r2 + && (!s1->as || s1->as->type != AS_ASSUMED_RANK) + && (!s2->as || s2->as->type != AS_ASSUMED_RANK)) return 0; /* Ranks differ. */ return gfc_compare_types (&s1->ts, &s2->ts) @@ -1634,7 +1636,14 @@ static void argument_rank_mismatch (const char *name, locus *where, int rank1, int rank2) { - if (rank1 == 0) + + /* TS 29113, C407b. */ + if (rank2 == -1) + { + gfc_error ("The assumed-rank array at %L requires that the dummy argument" + " '%s' has assumed-rank", where, name); + } + else if (rank1 == 0) { gfc_error ("Rank mismatch in argument '%s' at %L " "(scalar and rank-%d)", name, where, rank2); @@ -1742,7 +1751,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } /* F2008, 12.5.2.5; IR F08/0073. */ - if (formal->ts.type == BT_CLASS + if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL && ((CLASS_DATA (formal)->attr.class_pointer && !formal->attr.intent == INTENT_IN) || CLASS_DATA (formal)->attr.allocatable)) @@ -1859,7 +1868,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, " is modified", &actual->where, formal->name); } - if (symbol_rank (formal) == actual->rank) +/* if (symbol_rank (formal) == -1 && actual->rank == 0) + { + gfc_error ("Sorry, passing the scalar at %L to the assumed-rank dummy " + "argument '%s' is not yet supported", &actual->where, + formal->name); + return 0; + }*/ + + /* If the rank is the same or the formal argument has assumed-rank. */ + if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) return 1; if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as @@ -2288,11 +2306,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } - if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer - && (f->sym->attr.allocatable || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)) - { - if (where && (f->sym->attr.allocatable || !f->sym->attr.optional)) + if (a->expr->expr_type == EXPR_NULL + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer + && (f->sym->attr.allocatable || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + || (f->sym->ts.type == BT_CLASS + && !CLASS_DATA (f->sym)->attr.class_pointer + && (CLASS_DATA (f->sym)->attr.allocatable + || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) + { + if (where + && (f->sym->attr.optional + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable))) gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", where, f->sym->name); else if (where) @@ -2990,6 +3018,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); return; } + + /* TS 29113, C407b. */ + if (a->expr && a->expr->expr_type == EXPR_VARIABLE + && symbol_rank (a->expr->symtree->n.sym) == -1) + { + gfc_error ("Assumed-rank argument requires an explicit interface " + "at %L", &a->expr->where); + return; + } } return; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 60a74ca..87b903a 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2340,6 +2340,7 @@ mio_typespec (gfc_typespec *ts) static const mstring array_spec_types[] = { minit ("EXPLICIT", AS_EXPLICIT), + minit ("ASSUMED_RANK", AS_ASSUMED_RANK), minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), minit ("DEFERRED", AS_DEFERRED), minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index f1721ce..9f585d7 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -394,6 +394,10 @@ gfc_post_options (const char **pfilename) else if (!gfc_option.flag_automatic && gfc_option.gfc_flag_openmp) gfc_warning_now ("Flag -fno-automatic overwrites -frecursive implied by " "-fopenmp"); + else if (!gfc_option.flag_automatic + && gfc_option.coarray == GFC_FCOARRAY_OPENMP) + gfc_warning_now ("Flag -fno-automatic overwrites -frecursive implied by " + "-fcoarray=openmp"); else if (gfc_option.flag_max_stack_var_size != -2 && gfc_option.flag_recursive) gfc_warning_now ("Flag -frecursive overwrites -fmax-stack-var-size=%d", @@ -403,6 +407,14 @@ gfc_post_options (const char **pfilename) gfc_warning_now ("Flag -fmax-stack-var-size=%d overwrites -frecursive " "implied by -fopenmp", gfc_option.flag_max_stack_var_size); + else if (gfc_option.flag_max_stack_var_size != -2 + && gfc_option.coarray == GFC_FCOARRAY_OPENMP) + gfc_warning_now ("Flag -fmax-stack-var-size=%d overwrites -frecursive " + "implied by -fcoarray=openmp", + gfc_option.flag_max_stack_var_size); + + if (gfc_option.coarray == GFC_FCOARRAY_OPENMP) + gfc_option.gfc_flag_openmp = 1; /* Implement -frecursive as -fmax-stack-var-size=-1. */ if (gfc_option.flag_recursive) @@ -546,6 +558,8 @@ gfc_handle_coarray_option (const char *arg) gfc_option.coarray = GFC_FCOARRAY_SINGLE; else if (strcmp (arg, "lib") == 0) gfc_option.coarray = GFC_FCOARRAY_LIB; + else if (strcmp (arg, "openmp") == 0) + gfc_option.coarray = GFC_FCOARRAY_OPENMP; else gfc_fatal_error ("Argument to -fcoarray is not valid: %s", arg); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0434e08..c7f14a2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -63,7 +63,8 @@ static code_stack *cs_base = NULL; static int forall_flag; static int do_concurrent_flag; -static bool assumed_type_expr_allowed = false; +/* Nonzero for assumed rank and for assumed type. */ +static bool assumed_rank_type_expr_allowed = false; /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -239,7 +240,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc) || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank > 0)) + || (sym->as && sym->as->rank != 0)) { proc->attr.always_explicit = 1; sym->attr.always_explicit = 1; @@ -299,6 +300,7 @@ resolve_formal_arglist (gfc_symbol *proc) } if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + || (sym->as && sym->as->type == AS_ASSUMED_RANK) || sym->attr.pointer || sym->attr.allocatable || sym->attr.target || sym->attr.optional) { @@ -1599,7 +1601,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; - assumed_type_expr_allowed = true; + assumed_rank_type_expr_allowed = true; for (; arg; arg = arg->next) { @@ -1832,8 +1834,18 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, "component", &e->where); return FAILURE; } + + /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only + allowed for the first argument. + Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html + FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is that + the function-name resolution happens too late in that function. */ + if (inquiry_argument) + assumed_rank_type_expr_allowed = false; + } - assumed_type_expr_allowed = false; + assumed_rank_type_expr_allowed = false; return SUCCESS; } @@ -1895,7 +1907,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) /* The rank of an elemental is the rank of its array argument(s). */ for (arg = arg0; arg; arg = arg->next) { - if (arg->expr != NULL && arg->expr->rank > 0) + if (arg->expr != NULL && arg->expr->rank != 0) { rank = arg->expr->rank; if (arg->expr->expr_type == EXPR_VARIABLE @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* TS 29113, 6.2. */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_RANK) + { + gfc_error ("Procedure '%s' at %L with assumed-rank dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } /* F2008, 12.4.2.2 (2c) */ else if (arg->sym->attr.codimension) { @@ -2219,6 +2240,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + else if (arg->sym->ts.type == BT_ASSUMED) + { + gfc_error ("Procedure '%s' at %L with assumed-type dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } } if (def_sym->attr.function) @@ -4964,7 +4994,7 @@ expression_shape (gfc_expr *e) mpz_t array[GFC_MAX_DIMENSIONS]; int i; - if (e->rank == 0 || e->shape != NULL) + if (e->rank <= 0 || e->shape != NULL) return; for (i = 0; i < e->rank; i++) @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e) sym = e->symtree->n.sym; /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed) + if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed) { gfc_error ("Invalid expression with assumed-type variable %s at %L", sym->name, &e->where); return FAILURE; } + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && !assumed_rank_type_expr_allowed) + { + gfc_error ("Invalid expression with assumed-rank variable %s at %L", + sym->name, &e->where); + return FAILURE; + } + /* TS 29113, 407b. */ if (e->ts.type == BT_ASSUMED && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e) return FAILURE; } + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-rank variable %s with designator at %L", + sym->name, &e->ref->u.ar.where); + return FAILURE; + } + + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ @@ -5584,7 +5643,7 @@ update_ppc_arglist (gfc_expr* e) return FAILURE; /* F08:R739. */ - if (po->rank > 0) + if (po->rank != 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); return FAILURE; @@ -5632,7 +5691,7 @@ check_typebound_baseobject (gfc_expr* e) /* F08:C1230. If the procedure called is NOPASS, the base object must be scalar. */ - if (e->value.compcall.tbp->nopass && base->rank > 0) + if (e->value.compcall.tbp->nopass && base->rank != 0) { gfc_error ("Base object for NOPASS type-bound procedure call at %L must" " be scalar", &e->where); @@ -10269,7 +10328,7 @@ apply_default_init_local (gfc_symbol *sym) entry, so we just add a static initializer. Note that automatic variables are stack allocated even with -fno-automatic. */ if (sym->attr.save || sym->ns->save_all - || (gfc_option.flag_max_stack_var_size == 0 + || (gfc_option.flag_max_stack_var_size == 0 && !sym->attr.result && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) { /* Don't clobber an existing initializer! */ @@ -10319,10 +10378,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (allocatable) { - if (dimension) + if (dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Allocatable array '%s' at %L must have " - "a deferred shape", sym->name, &sym->declared_at); + gfc_error ("Allocatable array '%s' at %L must have a deferred " + "shape or assumed rank", sym->name, &sym->declared_at); return FAILURE; } else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L " @@ -10331,10 +10390,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } - if (pointer && dimension) + if (pointer && dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Array pointer '%s' at %L must have a deferred shape", - sym->name, &sym->declared_at); + gfc_error ("Array pointer '%s' at %L must have a deferred shape or " + "deferred rank", sym->name, &sym->declared_at); return FAILURE; } } @@ -10948,7 +11007,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) } /* Warn if the procedure is non-scalar and not assumed shape. */ - if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0 + if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0 && arg->as->type != AS_ASSUMED_SHAPE) gfc_warning ("Non-scalar FINAL procedure at %L should have assumed" " shape argument", &arg->declared_at); @@ -11477,7 +11536,7 @@ resolve_typebound_procedure (gfc_symtree* stree) } gcc_assert (me_arg->ts.type == BT_CLASS); - if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) { gfc_error ("Passed-object dummy argument of '%s' at %L must be" " scalar", proc->name, &where); @@ -12491,6 +12550,20 @@ resolve_symbol (gfc_symbol *sym) &sym->declared_at); return; } + /* TS 29113, C535a. */ + if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy) + { + gfc_error ("Assumed-rank array at %L must be a dummy argument", + &sym->declared_at); + return; + } + if (as->type == AS_ASSUMED_RANK + && (sym->attr.codimension || sym->attr.value)) + { + gfc_error ("Assumed-rank array at %L may not have the VALUE or " + "CODIMENSION attribute", &sym->declared_at); + return; + } } /* Make sure symbols with known intent or optional are really dummy @@ -12563,6 +12636,13 @@ resolve_symbol (gfc_symbol *sym) sym->name, &sym->declared_at); return; } + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) { gfc_error ("Assumed-type variable %s at %L shall not be an " diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 1578db1..10f654d 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) } - gfc_expr * gfc_simplify_is_iostat_end (gfc_expr *x) { @@ -3380,7 +3379,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE + || as->type == AS_ASSUMED_RANK)) return NULL; if (dim == NULL) @@ -3442,13 +3442,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > array->rank + if ((d < 1 || d > array->rank) || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; } + if (as && as->type == AS_ASSUMED_RANK) + return NULL; + return simplify_bound_dim (array, kind, d, upper, as, ref, false); } } @@ -4779,6 +4782,10 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * gfc_simplify_rank (gfc_expr *e) { + /* Assumed rank. */ + if (e->rank == -1) + return NULL; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f135af1..4281858 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -81,7 +81,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" +#include "gimple.h" /* For create_tmp_var_name. */ #include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" @@ -247,12 +247,11 @@ gfc_conv_descriptor_dtype (tree desc) desc, field, NULL_TREE); } -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) + +tree +gfc_get_descriptor_dimension (tree desc) { - tree field; - tree type; - tree tmp; + tree type, field; type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); @@ -262,10 +261,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - tmp = gfc_build_array_ref (tmp, dim, NULL); - return tmp; + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + + +static tree +gfc_conv_descriptor_dimension (tree desc, tree dim) +{ + tree tmp; + + tmp = gfc_get_descriptor_dimension (desc); + + return gfc_build_array_ref (tmp, dim, NULL); } @@ -311,6 +319,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim) if (integer_zerop (dim) && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; @@ -6906,9 +6915,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, } if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && !sym->attr.allocatable) + && sym->as + && sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_ASSUMED_RANK + && !sym->attr.allocatable) { /* Some variables are declared directly, others are declared as pointers and allocated on the heap. */ @@ -6944,10 +6954,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED + && sym->as->type != AS_ASSUMED_RANK && sym->as->type != AS_ASSUMED_SHAPE) || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED + && ref->u.ar.as->type != AS_ASSUMED_RANK && ref->u.ar.as->type != AS_ASSUMED_SHAPE) || gfc_is_simply_contiguous (expr, false)); @@ -8319,12 +8331,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) break; case AR_FULL: - newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); + newss = gfc_get_array_ss (ss, expr, + ar->as->rank < 0 ? GFC_MAX_DIMENSIONS + : ar->as->rank, + GFC_SS_SECTION); newss->info->data.array.ref = ref; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ - ar->dimen = ar->as->rank; + ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank; for (n = 0; n < ar->dimen; n++) { ar->dimen_type[n] = DIMEN_RANGE; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 9bafb94..b7ab806 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_dtype (tree); +tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); tree gfc_conv_descriptor_ubound_get (tree, tree); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 75a2160..9d5bb46 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) int n; bool known_size; - if (sym->attr.pointer || sym->attr.allocatable) + if (sym->attr.pointer || sym->attr.allocatable + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) return dummy; /* Add to list of variables if not a fake result variable. */ @@ -3669,6 +3670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); break; + case AS_ASSUMED_RANK: case AS_DEFERRED: seen_trans_deferred_array = true; gfc_trans_deferred_array (sym, block); @@ -4782,7 +4784,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) dummy argument is an array. (See "Sequence association" in Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ if (fsym->attr.pointer || fsym->attr.allocatable - || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE)) + || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK))) { comparison = NE_EXPR; message = _("Actual string length does not match the declared one" @@ -4848,7 +4851,8 @@ gfc_init_coarray_decl (bool main_tu) { tree save_fn_decl; - if (gfc_option.coarray != GFC_FCOARRAY_LIB) + if (gfc_option.coarray != GFC_FCOARRAY_LIB + && gfc_option.coarray != GFC_FCOARRAY_OPENMP) return; if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images) @@ -4867,6 +4871,10 @@ gfc_init_coarray_decl (bool main_tu) TREE_PUBLIC (gfort_gvar_caf_this_image) = 1; TREE_READONLY (gfort_gvar_caf_this_image) = 0; + if (gfc_option.coarray == GFC_FCOARRAY_OPENMP) + DECL_TLS_MODEL (gfort_gvar_caf_this_image) + = decl_default_tls_model (gfort_gvar_caf_this_image); + if (main_tu) TREE_STATIC (gfort_gvar_caf_this_image) = 1; else @@ -4901,7 +4909,7 @@ create_main_function (tree fndecl) tree old_context; tree ftn_main; tree tmp, decl, result_decl, argc, argv, typelist, arglist; - stmtblock_t body; + stmtblock_t body, block; old_context = current_function_decl; @@ -5108,13 +5116,38 @@ create_main_function (tree fndecl) gfc_add_expr_to_block (&body, tmp); } + if (gfc_option.coarray == GFC_FCOARRAY_OPENMP) + { + gfc_init_coarray_decl (true); + gfc_start_block (&block); + pushlevel (); + } + else + gfc_init_block (&block); + /* Call MAIN__(). */ tmp = build_call_expr_loc (input_location, fndecl, 0); - gfc_add_expr_to_block (&body, tmp); - - /* Mark MAIN__ as used. */ TREE_USED (fndecl) = 1; + gfc_add_expr_to_block (&block, tmp); + + if (gfc_option.coarray == GFC_FCOARRAY_OPENMP) + { +/* tmp = build_call_expr_loc (input_location, fndecl 0); + TREE_USED (tmp) = 1; + gfc_add_expr_to_block (&body, tmp); + +OMP_GET_THREAD_NUM*/ + tmp = gfc_finish_block (&block); + tree block2 = poplevel (1, 0); + tmp = build3_v (BIND_EXPR, NULL, tmp, block2); + + tmp = build2_loc (input_location, OMP_PARALLEL, void_type_node, tmp, + NULL_TREE); + gfc_add_expr_to_block (&body, tmp); + } + else + gfc_add_expr_to_block (&body, gfc_finish_block (&block)); /* Coarray: Call _gfortran_caf_finalize(void). */ if (gfc_option.coarray == GFC_FCOARRAY_LIB) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7d1a6d4..80baf94 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -42,6 +42,46 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" +/* Convert a scalar to an array descriptor. To be used for assumed-rank + arrays. */ + +static tree +get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) +{ + enum gfc_array_kind akind; + + if (attr.pointer) + akind = GFC_ARRAY_POINTER_CONT; + else if (attr.allocatable) + akind = GFC_ARRAY_ALLOCATABLE; + else + akind = GFC_ARRAY_ASSUMED_SHAPE_CONT; + + return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1, + akind, !(attr.pointer || attr.target)); +} + +static tree +conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) +{ + tree desc, type; + + type = get_scalar_to_descriptor_type (scalar, attr); + desc = gfc_create_var (type, "desc"); + DECL_ARTIFICIAL (desc) = 1; + gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&se->pre, desc, scalar); + + /* Copy pointer address back - but only if it could have changed and + if the actual argument is a pointer and not, e.g., NULL(). */ + if ((attr.pointer || attr.allocatable) + && !attr.intent == INTENT_IN && POINTER_TYPE_P (scalar)) + gfc_add_modify (&se->post, scalar, gfc_conv_descriptor_data_get (desc)); + return desc; +} + + /* This is the seed for an eventual trans-class.c The following parameters should not be used directly since they might @@ -158,7 +198,34 @@ gfc_get_vptr_from_expr (tree expr) tmp = gfc_class_vptr_get (tmp); return tmp; } - + + +static void +class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, + bool lhs_type) +{ + tree tmp, tmp2, type; + + gfc_conv_descriptor_data_set (block, lhs_desc, + gfc_conv_descriptor_data_get (rhs_desc)); + gfc_conv_descriptor_offset_set (block, lhs_desc, + gfc_conv_descriptor_offset_get (rhs_desc)); + + gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), + gfc_conv_descriptor_dtype (rhs_desc)); + + /* Assign the dimension as range-ref. */ + tmp = gfc_get_descriptor_dimension (lhs_desc); + tmp2 = gfc_get_descriptor_dimension (rhs_desc); + + type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, tmp, tmp2); +} + /* Takes a derived type expression and returns the address of a temporary class object of the 'declared' type. If vptr is not NULL, this is @@ -215,14 +282,35 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); - tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); - gfc_add_modify (&parmse->pre, ctree, tmp); + if (e->rank != class_ts.u.derived->components->as->rank) + { + tree type; + type = get_scalar_to_descriptor_type (parmse->expr, + gfc_expr_attr (e)); + gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr); + + if (gfc_expr_attr (e).pointer || gfc_expr_attr (e).allocatable) + gfc_add_modify (&parmse->post, parmse->expr, + gfc_conv_descriptor_data_get (ctree)); + } + else + { + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } } else { parmse->ss = ss; gfc_conv_expr_descriptor (parmse, e, ss); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + + if (e->rank != class_ts.u.derived->components->as->rank) + class_array_data_assign (&parmse->pre, ctree, parmse->expr, + TREE_TYPE (parmse->expr)); + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); } } @@ -260,7 +348,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, break; } - if (ref == NULL || class_ref == ref) + if ((ref == NULL || class_ref == ref) + && e->rank == class_ts.u.derived->components->as->rank) return; /* Test for FULL_ARRAY. */ @@ -273,13 +362,42 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, /* Set the data. */ ctree = gfc_class_data_get (var); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + { + if (e->rank == 0) + { + tree type = get_scalar_to_descriptor_type (parmse->expr, + gfc_expr_attr (e)); + gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&parmse->pre, ctree, + gfc_class_data_get (parmse->expr)); + + } + else + class_array_data_assign (&parmse->pre, ctree, parmse->expr, false); + } + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); /* Return the data component, except in the case of scalarized array references, where nullification of the cannot occur and so there is no need. */ if (!elemental && full_array) - gfc_add_modify (&parmse->post, parmse->expr, ctree); + { + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + { + if (e->rank == 0) + gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr), + gfc_conv_descriptor_data_get (ctree)); + else + class_array_data_assign (&parmse->post, parmse->expr, ctree, true); + } + else + gfc_add_modify (&parmse->post, parmse->expr, ctree); + } /* Set the vptr. */ ctree = gfc_class_vptr_get (var); @@ -730,7 +848,8 @@ gfc_conv_expr_present (gfc_symbol * sym) as actual argument to denote absent dummies. For array descriptors, we thus also need to check the array descriptor. */ if (!sym->attr.pointer && !sym->attr.allocatable - && sym->as && sym->as->type == AS_ASSUMED_SHAPE + && sym->as && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK) && (gfc_option.allow_std & GFC_STD_F2008) != 0) { tree tmp; @@ -1325,7 +1444,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym)) + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -3307,14 +3427,17 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER - && arg->next->expr->rank == 0) + else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) { - /* Convert c_f_pointer if fptr is a scalar - and convert c_f_procpointer. */ + /* Convert c_f_pointer and c_f_procpointer. */ gfc_se cptrse; gfc_se fptrse; + gfc_se shapese; + gfc_ss *ss, *shape_ss; + tree desc, dim, tmp, stride, offset; + stmtblock_t body, block, ifblock; + gfc_loopinfo loop; gfc_init_se (&cptrse, NULL); gfc_conv_expr (&cptrse, arg->expr); @@ -3322,25 +3445,113 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->post, &cptrse.post); gfc_init_se (&fptrse, NULL); - if (sym->intmod_sym_id == ISOCBINDING_F_POINTER - || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) - fptrse.want_pointer = 1; + if (arg->next->expr->rank == 0) + { + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER + || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) + fptrse.want_pointer = 1; + + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se->pre, &fptrse.pre); + gfc_add_block_to_block (&se->post, &fptrse.post); + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + return 1; + } - gfc_conv_expr (&fptrse, arg->next->expr); - gfc_add_block_to_block (&se->pre, &fptrse.pre); - gfc_add_block_to_block (&se->post, &fptrse.post); - - if (arg->next->expr->symtree->n.sym->attr.proc_pointer - && arg->next->expr->symtree->n.sym->attr.dummy) - fptrse.expr = build_fold_indirect_ref_loc (input_location, - fptrse.expr); - - se->expr = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); + gfc_start_block (&block); + + /* Get the descriptor of the Fortran pointer. */ + ss = gfc_walk_expr (arg->next->expr); + gcc_assert (ss != gfc_ss_terminator); + fptrse.descriptor_only = 1; + gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss); + gfc_add_block_to_block (&block, &fptrse.pre); + desc = fptrse.expr; + + /* Set data value, dtype, and offset. */ + tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); + gfc_conv_descriptor_data_set (&block, desc, + fold_convert (tmp, cptrse.expr)); + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (TREE_TYPE (desc))); + + /* Start scalarization of the bounds, using the shape argument. */ + + shape_ss = gfc_walk_expr (arg->next->next->expr); + gcc_assert (shape_ss != gfc_ss_terminator); + gfc_init_se (&shapese, NULL); + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, shape_ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_mark_ss_chain_used (shape_ss, 1); + + gfc_copy_loopinfo_to_se (&shapese, &loop); + shapese.ss = shape_ss; + + stride = gfc_create_var (gfc_array_index_type, "stride"); + offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block, stride, gfc_index_one_node); + gfc_add_modify (&block, offset, gfc_index_one_node); + + /* Loop body. */ + gfc_start_scalarized_body (&loop, &body); + dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + loop.loopvar[0], loop.from[0]); + + /* Set bounds and stride. */ + gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); + gfc_conv_descriptor_stride_set (&body, desc, dim, stride); + + gfc_conv_expr (&shapese, arg->next->next->expr); + gfc_add_block_to_block (&body, &shapese.pre); + gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + gfc_add_block_to_block (&body, &shapese.post); + + /* Calculate offset. */ + gfc_init_block (&ifblock); + gfc_add_modify (&ifblock, offset, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, stride)); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + loop.loopvar[0],loop.from[0]); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + gfc_finish_block (&ifblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + /* Update stride. */ + gfc_add_modify (&body, stride, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, + fold_convert (gfc_array_index_type, + shapese.expr))); + /* Finish scalarization loop. */ + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + gfc_add_block_to_block (&block, &fptrse.post); + gfc_cleanup_loop (&loop); + gfc_free_ss (ss); + + gfc_add_modify (&block, offset, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, offset, + build_int_cst (gfc_array_index_type, + -1))); + gfc_conv_descriptor_offset_set (&block, desc, offset); + + se->expr = gfc_finish_block (&block); return 1; } else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) @@ -3539,10 +3750,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } - else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer) + else if (arg->expr->expr_type == EXPR_NULL + && fsym && !fsym->attr.pointer + && (fsym->ts.type != BT_CLASS + || !CLASS_DATA (fsym)->attr.class_pointer)) { /* Pass a NULL pointer to denote an absent arg. */ - gcc_assert (fsym->attr.optional && !fsym->attr.allocatable); + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable + && (fsym->ts.type != BT_CLASS + || !CLASS_DATA (fsym)->attr.allocatable)); gfc_init_se (&parmse, NULL); parmse.expr = null_pointer_node; if (arg->missing_arg_type == BT_CHARACTER) @@ -3683,7 +3899,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, class object, if the formal argument is a class object. */ if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS - && CLASS_DATA (e)->attr.dimension) + && ((CLASS_DATA (fsym)->as + && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (e)->attr.dimension)) gfc_conv_class_to_class (&parmse, e, fsym->ts, false); if (fsym && (fsym->ts.type == BT_DERIVED @@ -3727,7 +3945,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->pre, tmp); } - if (fsym && e->expr_type != EXPR_NULL + /* Wrap scalar variable in a descriptor. We need to convert + the address of a pointer back to the pointer itself before, + we can assign it to the data field. */ + + if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK + && fsym->ts.type != BT_CLASS) + { + tmp = parmse.expr; + if (TREE_CODE (tmp) == ADDR_EXPR + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))) + tmp = TREE_OPERAND (tmp, 0); + parmse.expr = conv_scalar_to_descriptor (se, tmp, + gfc_expr_attr (e)); + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); + } + else if (fsym && e->expr_type != EXPR_NULL && ((fsym->attr.pointer && fsym->attr.flavor != FL_PROCEDURE) || (fsym->attr.proc_pointer @@ -3745,6 +3978,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parm_kind = SCALAR_POINTER; parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + } } else if (e->ts.type == BT_CLASS @@ -3769,7 +4003,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, bool f; f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE; + && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE + && fsym->as->type != AS_ASSUMED_RANK; if (comp) f = f || !comp->attr.always_explicit; else @@ -3878,12 +4113,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional - && ((e->rank > 0 && sym->attr.elemental) + && ((e->rank != 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER - || (e->rank > 0 + || (e->rank != 0 && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK || fsym->as->type == AS_DEFERRED)))))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); @@ -4129,7 +4365,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = caf_decl; } - if (fsym->as->type == AS_ASSUMED_SHAPE) + if (fsym->as->type == AS_ASSUMED_SHAPE + || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer + && !fsym->attr.allocatable)) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c74e81a..db2a486 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1316,29 +1316,37 @@ trans_num_images (gfc_se * se) } +static tree +get_rank_from_desc (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), + dtype, tmp); + return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); +} + + static void gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) { gfc_se argse; gfc_ss *ss; - tree dtype, tmp; ss = gfc_walk_expr (expr->value.function.actual->expr); gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); argse.data_not_needed = 1; - argse.want_pointer = 1; + argse.descriptor_only = 1; gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr); - argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr); - dtype = gfc_conv_descriptor_dtype (argse.expr); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); + + se->expr = get_rank_from_desc (argse.expr); } @@ -1360,6 +1368,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) gfc_se argse; gfc_ss *ss; gfc_array_spec * as; + bool assumed_rank_lb_one; arg = expr->value.function.actual; arg2 = arg->next; @@ -1401,27 +1410,40 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) desc = argse.expr; + as = gfc_get_full_arrayspec_from_expr (arg->expr); + + /* FIXME: Why is this extra indirect_ref required? */ +/* if (as->type == AS_ASSUMED_RANK) + desc = build_fold_indirect_ref_loc (input_location, desc);*/ + if (INTEGER_CST_P (bound)) { int hi, low; hi = TREE_INT_CST_HIGH (bound); low = TREE_INT_CST_LOW (bound); - if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + if (hi || low < 0 + || ((!as || as->type != AS_ASSUMED_RANK) + && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + || low > GFC_MAX_DIMENSIONS) gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " "dimension index", upper ? "UBOUND" : "LBOUND", &expr->where); } - else + + if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK)) { if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + if (as && as->type == AS_ASSUMED_RANK) + tmp = get_rank_from_desc (desc); + else + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - bound, tmp); + bound, fold_convert(TREE_TYPE (bound), tmp)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -1429,11 +1451,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) } } + /* Take care of the lbound shift for assumed-rank arrays, which are + nonallocatable and nonpointers. Those has a lbound of 1. */ + assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK + && ((arg->expr->ts.type != BT_CLASS + && !arg->expr->symtree->n.sym->attr.allocatable + && !arg->expr->symtree->n.sym->attr.pointer) + || (arg->expr->ts.type == BT_CLASS + && !CLASS_DATA (arg->expr)->attr.allocatable + && !CLASS_DATA (arg->expr)->attr.class_pointer)); + ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (desc, bound); - as = gfc_get_full_arrayspec_from_expr (arg->expr); - /* 13.14.53: Result value for LBOUND Case (i): For an array section or for an array expression other than a @@ -1455,7 +1485,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) not have size zero and has value zero if dimension DIM has size zero. */ - if (as) + if (!upper && assumed_rank_lb_one) + se->expr = gfc_index_one_node; + else if (as) { tree stride = gfc_conv_descriptor_stride_get (desc, bound); @@ -1481,9 +1513,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, cond, cond5); + if (assumed_rank_lb_one) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); + } + else + tmp = ubound; + se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - ubound, gfc_index_zero_node); + tmp, gfc_index_zero_node); } else { @@ -5856,8 +5898,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) present. */ arg1se.descriptor_only = 1; gfc_conv_expr_lhs (&arg1se, arg1->expr); - tmp = gfc_conv_descriptor_stride_get (arg1se.expr, - gfc_rank_cst[arg1->expr->rank - 1]); + if (arg1->expr->rank == -1) + { + tmp = get_rank_from_desc (arg1se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (tmp), tmp, gfc_index_one_node); + } + else + tmp = gfc_rank_cst[arg1->expr->rank - 1]; + tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index aa50e3d..d96f5e6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -80,8 +80,8 @@ bool gfc_real16_is_float128 = false; static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; -static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS]; -static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS]; +static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; +static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; /* 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. */ @@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym) return 0; if (sym->attr.dummy) - return sym->as->type != AS_ASSUMED_SHAPE; + return sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_ASSUMED_RANK; if (sym->attr.result || sym->attr.function) return 0; @@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as, tree ubound[GFC_MAX_DIMENSIONS]; int n; + if (as->type == AS_ASSUMED_RANK) + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + lbound[n] = NULL_TREE; + ubound[n] = NULL_TREE; + } + for (n = 0; n < as->rank; n++) { /* Create expressions for the known bounds of the array. */ @@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as, if (as->type == AS_ASSUMED_SHAPE) akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT : GFC_ARRAY_ASSUMED_SHAPE; - return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, + else if (as->type == AS_ASSUMED_RANK) + akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT + : GFC_ARRAY_ASSUMED_RANK; + return gfc_get_array_type_bounds (type, as->rank == -1 + ? GFC_MAX_DIMENSIONS : as->rank, + as->corank, lbound, ubound, 0, akind, restricted); } @@ -1682,9 +1695,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, { tree fat_type, decl, arraytype, *chain = NULL; char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; - int idx = 2 * (codimen + dimen - 1) + restricted; + int idx; + + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + + idx = 2 * (codimen + dimen) + restricted; - gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); + gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS); if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen) { @@ -1721,16 +1740,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, TREE_NO_WARNING (decl) = 1; /* Build the array type for the stride and bound components. */ - arraytype = - build_array_type (gfc_get_desc_dim_type (), - build_range_type (gfc_array_index_type, - gfc_index_zero_node, - gfc_rank_cst[codimen + dimen - 1])); + if (dimen + codimen > 0) + { + arraytype = + build_array_type (gfc_get_desc_dim_type (), + build_range_type (gfc_array_index_type, + gfc_index_zero_node, + gfc_rank_cst[codimen + dimen - 1])); - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("dim"), - arraytype, &chain); - TREE_NO_WARNING (decl) = 1; + decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), + arraytype, &chain); + TREE_NO_WARNING (decl) = 1; + } if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen && akind == GFC_ARRAY_ALLOCATABLE) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3b77281..d4092f7 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -765,6 +765,8 @@ enum gfc_array_kind GFC_ARRAY_UNKNOWN, GFC_ARRAY_ASSUMED_SHAPE, GFC_ARRAY_ASSUMED_SHAPE_CONT, + GFC_ARRAY_ASSUMED_RANK, + GFC_ARRAY_ASSUMED_RANK_CONT, GFC_ARRAY_ALLOCATABLE, GFC_ARRAY_POINTER, GFC_ARRAY_POINTER_CONT --- /dev/null 2012-06-30 08:05:14.091716208 +0200 +++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 2012-07-04 17:39:55.000000000 +0200 @@ -0,0 +1,64 @@ +program main + implicit none + + interface + subroutine check (x) + integer :: x(..) + end subroutine check + end interface + + integer, target :: ii, j + integer, allocatable :: kk + integer, pointer :: ll + ii = 489 + j = 0 + call f (ii) + call f (489) + call f () + call f (null()) + call f (kk) + if (j /= 2) call abort() + + j = 0 + nullify (ll) + call g (null()) + call g (ll) + call g (ii) + if (j /= 1) call abort() + + j = 0 + call h (kk) + kk = 489 + call h (kk) + if (j /= 1) call abort() + +contains + + subroutine f (x) + integer, optional :: x(..) + + if (.not. present (x)) return + if (rank (x) /= 0) call abort + call check (x) + j = j + 1 + end subroutine + + subroutine g (x) + integer, pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (rank (x) /= 0) call abort () + call check (x) + j = j + 1 + end subroutine + + subroutine h (x) + integer, allocatable :: x(..) + + if (.not. allocated (x)) return + if (rank (x) /= 0) call abort + call check (x) + j = j + 1 + end subroutine + +end program main --- /dev/null 2012-06-30 08:05:14.091716208 +0200 +++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8a.f90 2012-07-04 18:56:46.000000000 +0200 @@ -0,0 +1,132 @@ +program main + implicit none + + type t + integer :: i + end type t + + interface + subroutine check (x) + integer :: x(..) + end subroutine check + subroutine check2 (x) + import t + class(t) :: x(..) + end subroutine check2 + end interface + + integer :: j + + type(t), target :: y + class(t), allocatable, target :: yac + + y%i = 489 + allocate (yac) + yac%i = 489 + j = 0 + call fc() + call fc(null()) + call fc(y) + call fc(yac) + if (j /= 2) call abort () + + j = 0 + call gc(null()) + call gc(y) + call gc(yac) + deallocate (yac) + call gc(yac) + if (j /= 2) call abort () + + j = 0 + call hc(yac) + allocate (yac) + yac%i = 489 + call hc(yac) + if (j /= 1) call abort () + + j = 0 + call ft() + call ft(null()) + call ft(y) + call ft(yac) + if (j /= 2) call abort () + + j = 0 + call gt(null()) + call gt(y) + call gt(yac) + deallocate (yac) + call gt(yac) + if (j /= 2) call abort () + + j = 0 + call ht(yac) + allocate (yac) + yac%i = 489 + call ht(yac) + if (j /= 1) call abort () + +contains + + subroutine fc (x) + class(t), optional :: x(..) + + if (.not. present (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort + call check2 (x) + j = j + 1 + end subroutine + + subroutine gc (x) + class(t), pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort () + call check2 (x) + j = j + 1 + end subroutine + + subroutine hc (x) + class(t), allocatable :: x(..) + + if (.not. allocated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort + call check2 (x) + j = j + 1 + end subroutine + + subroutine ft (x) + type(t), optional :: x(..) + + if (.not. present (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort + call check2 (x) + j = j + 1 + end subroutine + + subroutine gt (x) + type(t), pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort () + call check2 (x) + j = j + 1 + end subroutine + + subroutine ht (x) + type(t), allocatable :: x(..) + + if (.not. allocated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) call abort () + if (rank (x) /= 0) call abort + call check2 (x) + j = j + 1 + end subroutine + +end program main --- /dev/null 2012-06-30 08:05:14.091716208 +0200 +++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c 2012-07-04 15:39:14.000000000 +0200 @@ -0,0 +1,23 @@ +#include + +struct a { + int *dat; +}; + +struct b { + struct a _data; +}; + + +void check_ (struct a *x) +{ + if (*x->dat != 489) + abort (); +} + + +void check2_ (struct b *x) +{ + if (*x->_data.dat != 489) + abort (); +}