From a5fbc2f36a291cbe80c4393950d6db9b56a34b05 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 1 Nov 2018 19:36:08 +0000 Subject: [PATCH] re PR fortran/40196 ([F03] [F08] Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)) 2018-11-01 Paul Thomas PR fortran/40196 * dependency.c (are_identical_variables): Return false if the inquiry refs are not the same. (gfc_ref_needs_temporary_p): Break on an inquiry ref. * dump_parse_tree.c (show_ref): Show the inquiry ref type. * expr.c (gfc_free_ref_list): Break on an inquiry ref. (gfc_copy_ref): Copy the inquiry ref types. (find_inquiry_ref): New function. (simplify_const_ref, simplify_ref_chain): Call it. Add new arg to simplify_ref_chain. (gfc_simplify_expr): Use the new arg in call to simplify_ref_chain. (gfc_get_full_arrayspec_from_expr, gfc_is_coarray): Break on inquiry ref. (gfc_traverse_expr): Return true for inquiry ref. * frontend-passes.c (gfc_expr_walker): Break on inquiry ref. * gfortran.h : Add enums and union member in gfc_ref to implement inquiry refs. * intrinsic.c : Fix white nois. * match.c (gfc_match_assignment): A constant lavlue is an error. * module.c : Add DECL_MIO_NAME for inquiry_type and the mstring for inquiry_types. (mio_ref): Handle inquiry refs. * primary.c (is_inquiry_ref): New function. (gfc_match_varspec): Handle inquiry refs calling new function. (gfc_variable_attr): Detect inquiry ref for disambiguation with components. (caf_variable_attr): Treat inquiry and substring refs in the same way. * resolve.c (find_array_spec): ditto. (gfc_resolve_substring_charlen): If there is neither a charlen ref not an inquiry ref, return. (resolve_ref): Handle inqiry refs as appropriate. (resolve_allocate_expr): Entities with an inquiry ref cannot be allocated. * simplify.c (simplify_bound, simplify_cobound): Punt on inquiry refs. * trans-array.c (get_array_ctor_var_strlen): Break on inquiry ref. *trans-expr.c (conv_inquiry): New function. (gfc_conv_variable): Retain the last typespec to pass to conv_inquiry on detecting an inquiry ref. 2018-11-01 Paul Thomas PR fortran/40196 * gfortran.dg/inquiry_part_ref_1.f08: New test. * gfortran.dg/inquiry_part_ref_2.f90: New test. * gfortran.dg/inquiry_part_ref_3.f90: New test. From-SVN: r265729 --- gcc/fortran/ChangeLog | 46 +++++ gcc/fortran/dependency.c | 6 + gcc/fortran/dump-parse-tree.c | 19 +- gcc/fortran/expr.c | 167 ++++++++++++++-- gcc/fortran/frontend-passes.c | 1 + gcc/fortran/gfortran.h | 7 +- gcc/fortran/intrinsic.c | 2 +- gcc/fortran/match.c | 8 + gcc/fortran/module.c | 14 ++ gcc/fortran/primary.c | 189 ++++++++++++++++-- gcc/fortran/resolve.c | 11 +- gcc/fortran/simplify.c | 4 +- gcc/fortran/trans-array.c | 3 + gcc/fortran/trans-expr.c | 41 ++++ gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/inquiry_type_ref_1.f08 | 55 +++++ .../gfortran.dg/inquiry_type_ref_2.f90 | 17 ++ .../gfortran.dg/inquiry_type_ref_3.f90 | 30 +++ 18 files changed, 589 insertions(+), 38 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 create mode 100644 gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 87f3312eeef..31e3fdd12ec 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,49 @@ +2018-11-01 Paul Thomas + + PR fortran/40196 + * dependency.c (are_identical_variables): Return false if the + inquiry refs are not the same. + (gfc_ref_needs_temporary_p): Break on an inquiry ref. + * dump_parse_tree.c (show_ref): Show the inquiry ref type. + * expr.c (gfc_free_ref_list): Break on an inquiry ref. + (gfc_copy_ref): Copy the inquiry ref types. + (find_inquiry_ref): New function. + (simplify_const_ref, simplify_ref_chain): Call it. Add new arg + to simplify_ref_chain. + (gfc_simplify_expr): Use the new arg in call to + simplify_ref_chain. + (gfc_get_full_arrayspec_from_expr, gfc_is_coarray): Break on + inquiry ref. + (gfc_traverse_expr): Return true for inquiry ref. + * frontend-passes.c (gfc_expr_walker): Break on inquiry ref. + * gfortran.h : Add enums and union member in gfc_ref to + implement inquiry refs. + * intrinsic.c : Fix white nois. + * match.c (gfc_match_assignment): A constant lavlue is an + error. + * module.c : Add DECL_MIO_NAME for inquiry_type and the mstring + for inquiry_types. + (mio_ref): Handle inquiry refs. + * primary.c (is_inquiry_ref): New function. + (gfc_match_varspec): Handle inquiry refs calling new function. + (gfc_variable_attr): Detect inquiry ref for disambiguation + with components. + (caf_variable_attr): Treat inquiry and substring refs in the + same way. + * resolve.c (find_array_spec): ditto. + (gfc_resolve_substring_charlen): If there is neither a charlen + ref not an inquiry ref, return. + (resolve_ref): Handle inqiry refs as appropriate. + (resolve_allocate_expr): Entities with an inquiry ref cannot be + allocated. + * simplify.c (simplify_bound, simplify_cobound): Punt on + inquiry refs. + * trans-array.c (get_array_ctor_var_strlen): Break on inquiry + ref. + *trans-expr.c (conv_inquiry): New function. + (gfc_conv_variable): Retain the last typespec to pass to + conv_inquiry on detecting an inquiry ref. + 2018-11-01 Thomas Koenig PR fortran/46020 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 86359e5967e..b78c138c483 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -189,6 +189,11 @@ are_identical_variables (gfc_expr *e1, gfc_expr *e2) break; + case REF_INQUIRY: + if (r1->u.i != r2->u.i) + return false; + break; + default: gfc_internal_error ("are_identical_variables: Bad type"); } @@ -905,6 +910,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref) return subarray_p; case REF_COMPONENT: + case REF_INQUIRY: break; } diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f1be5a67a26..af64588786a 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -308,6 +308,23 @@ show_ref (gfc_ref *p) fputc (')', dumpfile); break; + case REF_INQUIRY: + switch (p->u.i) + { + case INQUIRY_KIND: + fprintf (dumpfile, " INQUIRY_KIND "); + break; + case INQUIRY_LEN: + fprintf (dumpfile, " INQUIRY_LEN "); + break; + case INQUIRY_RE: + fprintf (dumpfile, " INQUIRY_RE "); + break; + case INQUIRY_IM: + fprintf (dumpfile, " INQUIRY_IM "); + } + break; + default: gfc_internal_error ("show_ref(): Bad component code"); } @@ -3167,7 +3184,7 @@ write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, fputs (sym_name, dumpfile); fputs (post, dumpfile); - + if (rok == T_WARN) fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */", gfc_typename (ts)); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index f68204f1ed8..1d1d48d0b81 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -599,6 +599,7 @@ gfc_free_ref_list (gfc_ref *p) break; case REF_COMPONENT: + case REF_INQUIRY: break; } @@ -756,6 +757,10 @@ gfc_copy_ref (gfc_ref *src) dest->u.c = src->u.c; break; + case REF_INQUIRY: + dest->u.i = src->u.i; + break; + case REF_SUBSTRING: dest->u.ss = src->u.ss; dest->u.ss.start = gfc_copy_expr (src->u.ss.start); @@ -1691,6 +1696,109 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) } +/* Pull an inquiry result out of an expression. */ + +static bool +find_inquiry_ref (gfc_expr *p, gfc_expr **newp) +{ + gfc_ref *ref; + gfc_ref *inquiry = NULL; + gfc_expr *tmp; + + tmp = gfc_copy_expr (p); + + if (tmp->ref && tmp->ref->type == REF_INQUIRY) + { + inquiry = tmp->ref; + tmp->ref = NULL; + } + else + { + for (ref = tmp->ref; ref; ref = ref->next) + if (ref->next && ref->next->type == REF_INQUIRY) + { + inquiry = ref->next; + ref->next = NULL; + } + } + + if (!inquiry) + { + gfc_free_expr (tmp); + return false; + } + + gfc_resolve_expr (tmp); + + switch (inquiry->u.i) + { + case INQUIRY_LEN: + if (tmp->ts.type != BT_CHARACTER) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + goto cleanup; + + if (!tmp->ts.u.cl->length + || tmp->ts.u.cl->length->expr_type != EXPR_CONSTANT) + goto cleanup; + + *newp = gfc_copy_expr (tmp->ts.u.cl->length); + break; + + case INQUIRY_KIND: + if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) + goto cleanup; + + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp->ts.kind); + break; + + case INQUIRY_RE: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_realref (p->value.complex), GFC_RND_MODE); + break; + + case INQUIRY_IM: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_imagref (p->value.complex), GFC_RND_MODE); + break; + } + + if (!(*newp)) + goto cleanup; + else if ((*newp)->expr_type != EXPR_CONSTANT) + { + gfc_free_expr (*newp); + goto cleanup; + } + + gfc_free_expr (tmp); + return true; + +cleanup: + gfc_free_expr (tmp); + return false; +} + + /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ @@ -1699,7 +1807,7 @@ static bool simplify_const_ref (gfc_expr *p) { gfc_constructor *cons, *c; - gfc_expr *newp; + gfc_expr *newp = NULL; gfc_ref *last_ref; while (p->ref) @@ -1800,8 +1908,17 @@ simplify_const_ref (gfc_expr *p) remove_subobject_ref (p, cons); break; + case REF_INQUIRY: + if (!find_inquiry_ref (p, &newp)) + return false; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + case REF_SUBSTRING: - if (!find_substring_ref (p, &newp)) + if (!find_substring_ref (p, &newp)) return false; gfc_replace_expr (p, newp); @@ -1818,9 +1935,10 @@ simplify_const_ref (gfc_expr *p) /* Simplify a chain of references. */ static bool -simplify_ref_chain (gfc_ref *ref, int type) +simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) { int n; + gfc_expr *newp; for (; ref; ref = ref->next) { @@ -1845,6 +1963,15 @@ simplify_ref_chain (gfc_ref *ref, int type) return false; break; + case REF_INQUIRY: + if (!find_inquiry_ref (*p, &newp)) + return false; + + gfc_replace_expr (*p, newp); + gfc_free_ref_list ((*p)->ref); + (*p)->ref = NULL; + break; + default: break; } @@ -1933,6 +2060,9 @@ gfc_simplify_expr (gfc_expr *p, int type) switch (p->expr_type) { case EXPR_CONSTANT: + if (p->ref && p->ref->type == REF_INQUIRY) + simplify_ref_chain (p->ref, type, &p); + break; case EXPR_NULL: break; @@ -1969,7 +2099,7 @@ gfc_simplify_expr (gfc_expr *p, int type) break; case EXPR_SUBSTRING: - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; if (gfc_is_constant_expr (p)) @@ -2031,14 +2161,14 @@ gfc_simplify_expr (gfc_expr *p, int type) } /* Simplify subcomponent references. */ - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; break; case EXPR_STRUCTURE: case EXPR_ARRAY: - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; if (!simplify_constructor (p->value.constructor, type)) @@ -3306,14 +3436,22 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, sym = lvalue->symtree->n.sym; - /* See if this is the component or subcomponent of a pointer. */ + /* See if this is the component or subcomponent of a pointer and guard + against assignment to LEN or KIND part-refs. */ has_pointer = sym->attr.pointer; for (ref = lvalue->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) - { - has_pointer = 1; - break; - } + { + if (!has_pointer && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pointer) + has_pointer = 1; + else if (ref->type == REF_INQUIRY + && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) + { + gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " + "allowed", &lvalue->where); + return false; + } + } /* 12.5.2.2, Note 12.26: The result variable is very similar to any other variable local to a function subprogram. Its existence begins when @@ -4791,6 +4929,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr) continue; case REF_SUBSTRING: + case REF_INQUIRY: continue; case REF_ARRAY: @@ -4943,6 +5082,9 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, } break; + case REF_INQUIRY: + return true; + default: gcc_unreachable (); } @@ -5297,6 +5439,7 @@ gfc_is_coarray (gfc_expr *e) break; case REF_SUBSTRING: + case REF_INQUIRY: break; } diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index a6af96c43db..2c095cb8d5e 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -5037,6 +5037,7 @@ gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) break; case REF_COMPONENT: + case REF_INQUIRY: break; } } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4a8d3602d72..d8ef35d9d6c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1937,7 +1937,10 @@ gfc_array_ref; before the component component. */ enum ref_type - { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING }; + { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING, REF_INQUIRY }; + +enum inquiry_type + { INQUIRY_RE, INQUIRY_IM, INQUIRY_KIND, INQUIRY_LEN }; typedef struct gfc_ref { @@ -1961,6 +1964,8 @@ typedef struct gfc_ref } ss; + inquiry_type i; + } u; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 17978c14d93..8c18706958d 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3367,7 +3367,7 @@ add_subroutines (void) *st = "status", *stat = "stat", *sz = "size", *t = "to", *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit", *val = "value", *vl = "values", *whence = "whence", *zn = "zone"; - + int di, dr, dc, dl, ii; di = gfc_default_integer_kind; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index badd3c4a5de..f22241da60b 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1350,6 +1350,14 @@ gfc_match_assignment (void) rvalue = NULL; m = gfc_match (" %e%t", &rvalue); + + if (lvalue->expr_type == EXPR_CONSTANT) + { + /* This clobbers %len and %kind. */ + m = MATCH_ERROR; + gfc_error ("Assignment to a constant expression at %C"); + } + if (m != MATCH_YES) { gfc_current_locus = old_loc; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 7b8e863ca0a..d42ab4789eb 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2125,6 +2125,7 @@ DECL_MIO_NAME (procedure_type) DECL_MIO_NAME (ref_type) DECL_MIO_NAME (sym_flavor) DECL_MIO_NAME (sym_intent) +DECL_MIO_NAME (inquiry_type) #undef DECL_MIO_NAME /* Symbol attributes are stored in list with the first three elements @@ -3140,6 +3141,15 @@ static const mstring ref_types[] = { minit ("ARRAY", REF_ARRAY), minit ("COMPONENT", REF_COMPONENT), minit ("SUBSTRING", REF_SUBSTRING), + minit ("INQUIRY", REF_INQUIRY), + minit (NULL, -1) +}; + +static const mstring inquiry_types[] = { + minit ("RE", INQUIRY_RE), + minit ("IM", INQUIRY_IM), + minit ("KIND", INQUIRY_KIND), + minit ("LEN", INQUIRY_LEN), minit (NULL, -1) }; @@ -3170,6 +3180,10 @@ mio_ref (gfc_ref **rp) mio_expr (&r->u.ss.end); mio_charlen (&r->u.ss.length); break; + + case REF_INQUIRY: + r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types); + break; } mio_rparen (); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 6f45afa86ea..d94a5c48adf 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1249,7 +1249,7 @@ match_sym_complex_part (gfc_expr **result) if (sym->attr.flavor != FL_PARAMETER) { /* Give the matcher for implied do-loops a chance to run. This yields - a much saner error message for "write(*,*) (i, i=1, 6" where the + a much saner error message for "write(*,*) (i, i=1, 6" where the right parenthesis is missing. */ char c; gfc_gobble_whitespace (); @@ -1936,6 +1936,40 @@ extend_ref (gfc_expr *primary, gfc_ref *tail) } +/* Used by gfc_match_varspec() to match an inquiry reference. */ + +static bool +is_inquiry_ref (const char *name, gfc_ref **ref) +{ + inquiry_type type; + + if (name == NULL) + return false; + + if (ref) *ref = NULL; + + if (strcmp (name, "re") == 0) + type = INQUIRY_RE; + else if (strcmp (name, "im") == 0) + type = INQUIRY_IM; + else if (strcmp (name, "kind") == 0) + type = INQUIRY_KIND; + else if (strcmp (name, "len") == 0) + type = INQUIRY_LEN; + else + return false; + + if (ref) + { + *ref = gfc_get_ref (); + (*ref)->type = REF_INQUIRY; + (*ref)->u.i = type; + } + + return true; +} + + /* Match any additional specifications associated with the current variable like member references or substrings. If equiv_flag is set we only match stuff that is allowed inside an EQUIVALENCE @@ -1955,6 +1989,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, gfc_expr *tgt_expr = NULL; match m; bool unknown; + bool inquiry; + locus old_loc; char sep; tail = NULL; @@ -2087,6 +2123,19 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m == MATCH_ERROR) return MATCH_ERROR; + inquiry = false; + if (m == MATCH_YES && sep == '%' + && primary->ts.type != BT_CLASS + && primary->ts.type != BT_DERIVED) + { + match mm; + old_loc = gfc_current_locus; + mm = gfc_match_name (name); + if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)) + inquiry = true; + gfc_current_locus = old_loc; + } + if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); @@ -2118,18 +2167,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, } } else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - && m == MATCH_YES) + && m == MATCH_YES && !inquiry) { gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C", sep, sym->name); return MATCH_ERROR; } - if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) + if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry) || m != MATCH_YES) goto check_substring; - sym = sym->ts.u.derived; + if (!inquiry) + sym = sym->ts.u.derived; + else + sym = NULL; for (;;) { @@ -2142,6 +2194,15 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return MATCH_ERROR; + if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) + { + inquiry = is_inquiry_ref (name, &tmp); + if (inquiry) + sym = NULL; + } + else + inquiry = false; + if (sym && sym->f2k_derived) tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); else @@ -2197,24 +2258,89 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, break; } - component = gfc_find_component (sym, name, false, false, &tmp); - if (component == NULL) + if (!inquiry) + component = gfc_find_component (sym, name, false, false, &tmp); + else + component = NULL; + + if (component == NULL && !inquiry) return MATCH_ERROR; - /* Extend the reference chain determined by gfc_find_component. */ + /* Extend the reference chain determined by gfc_find_component or + is_inquiry_ref. */ if (primary->ref == NULL) - primary->ref = tmp; + primary->ref = tmp; else - { - /* Set by the for loop below for the last component ref. */ - gcc_assert (tail != NULL); - tail->next = tmp; - } + { + /* Set by the for loop below for the last component ref. */ + gcc_assert (tail != NULL); + tail->next = tmp; + } /* The reference chain may be longer than one hop for union - subcomponents; find the new tail. */ + subcomponents; find the new tail. */ for (tail = tmp; tail->next; tail = tail->next) - ; + ; + + if (tmp && tmp->type == REF_INQUIRY) + { + gfc_simplify_expr (primary, 0); + + if (primary->expr_type == EXPR_CONSTANT) + goto check_done; + + switch (tmp->u.i) + { + case INQUIRY_RE: + case INQUIRY_IM: + if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type != BT_COMPLEX) + { + gfc_error ("The RE or IM part_ref at %C must be " + "applied to a COMPLEX expression"); + return MATCH_ERROR; + } + primary->ts.type = BT_REAL; + break; + + case INQUIRY_LEN: + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type != BT_CHARACTER) + { + gfc_error ("The LEN part_ref at %C must be applied " + "to a CHARACTER expression"); + return MATCH_ERROR; + } + primary->ts.u.cl = NULL; + primary->ts.type = BT_INTEGER; + primary->ts.kind = gfc_default_integer_kind; + break; + + case INQUIRY_KIND: + if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type == BT_CLASS + || primary->ts.type == BT_DERIVED) + { + gfc_error ("The KIND part_ref at %C must be applied " + "to an expression of intrinsic type"); + return MATCH_ERROR; + } + primary->ts.type = BT_INTEGER; + primary->ts.kind = gfc_default_integer_kind; + break; + + default: + gcc_unreachable (); + } + + goto check_done; + } primary->ts = component->ts; @@ -2263,11 +2389,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, return m; } +check_done: + /* In principle, we could have eg. expr%re%kind so we must allow for + this possibility. */ + if (gfc_match_char ('%') == MATCH_YES) + { + if (component && (component->ts.type == BT_DERIVED + || component->ts.type == BT_CLASS)) + sym = component->ts.u.derived; + continue; + } + else if (inquiry) + break; + if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) - || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) + || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) break; - sym = component->ts.u.derived; + if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS) + sym = component->ts.u.derived; } check_substring: @@ -2358,6 +2498,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) gfc_ref *ref; gfc_symbol *sym; gfc_component *comp; + bool has_inquiry_part; if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); @@ -2387,6 +2528,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (ts != NULL && expr->ts.type == BT_UNKNOWN) *ts = sym->ts; + has_inquiry_part = false; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_INQUIRY) + { + has_inquiry_part = true; + break; + } + for (ref = expr->ref; ref; ref = ref->next) switch (ref->type) { @@ -2423,7 +2572,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) case REF_COMPONENT: comp = ref->u.c.component; attr = comp->attr; - if (ts != NULL) + if (ts != NULL && !has_inquiry_part) { *ts = comp->ts; /* Don't set the string length if a substring reference @@ -2450,6 +2599,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; + case REF_INQUIRY: case REF_SUBSTRING: allocatable = pointer = 0; break; @@ -2630,6 +2780,7 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp) break; case REF_SUBSTRING: + case REF_INQUIRY: allocatable = pointer = 0; break; } @@ -2914,7 +3065,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c to = e < c ? e : c; for (i = 0; i < to; i++) dest[i] = actual->expr->value.character.string[i]; - + for (i = e; i < c; i++) dest[i] = ' '; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7ec9e969c71..ba9623497d2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4740,6 +4740,7 @@ find_array_spec (gfc_expr *e) break; case REF_SUBSTRING: + case REF_INQUIRY: break; } @@ -4962,13 +4963,13 @@ gfc_resolve_substring_charlen (gfc_expr *e) for (char_ref = e->ref; char_ref; char_ref = char_ref->next) { - if (char_ref->type == REF_SUBSTRING) - break; + if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) + break; if (char_ref->type == REF_COMPONENT) ts = &char_ref->u.c.component->ts; } - if (!char_ref) + if (!char_ref || char_ref->type == REF_INQUIRY) return; gcc_assert (char_ref->next == NULL); @@ -5056,6 +5057,7 @@ resolve_ref (gfc_expr *expr) break; case REF_COMPONENT: + case REF_INQUIRY: break; case REF_SUBSTRING: @@ -5129,6 +5131,7 @@ resolve_ref (gfc_expr *expr) break; case REF_SUBSTRING: + case REF_INQUIRY: break; } @@ -7233,6 +7236,7 @@ resolve_deallocate_expr (gfc_expr *e) break; case REF_SUBSTRING: + case REF_INQUIRY: allocatable = 0; break; } @@ -7525,6 +7529,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) break; case REF_SUBSTRING: + case REF_INQUIRY: allocatable = 0; pointer = 0; break; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 2c87ae95f98..cdf748e4990 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4182,6 +4182,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) continue; case REF_SUBSTRING: + case REF_INQUIRY: continue; } } @@ -4324,6 +4325,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) continue; case REF_SUBSTRING: + case REF_INQUIRY: continue; } } @@ -5395,7 +5397,7 @@ gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, back_val = back->value.logical; } - + if (sign < 0) init_val = INT_MAX; else if (sign > 0) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 47fec131c78..04fb4262b24 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2078,6 +2078,9 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) mpz_clear (char_len); return; + case REF_INQUIRY: + break; + default: gcc_unreachable (); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 05b1d07eb02..64bda4c1e69 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2510,6 +2510,40 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) conv_parent_component_references (se, &parent); } + +static void +conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) +{ + tree res = se->expr; + + switch (ref->u.i) + { + case INQUIRY_RE: + res = fold_build1_loc (input_location, REALPART_EXPR, + TREE_TYPE (TREE_TYPE (res)), res); + break; + + case INQUIRY_IM: + res = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (res)), res); + break; + + case INQUIRY_KIND: + res = build_int_cst (gfc_typenode_for_spec (&expr->ts), + ts->kind); + break; + + case INQUIRY_LEN: + res = fold_convert (gfc_typenode_for_spec (&expr->ts), + se->string_length); + break; + + default: + gcc_unreachable (); + } + se->expr = res; +} + /* Return the contents of a variable. Also handles reference/pointer variables (all Fortran pointer references are implicit). */ @@ -2720,6 +2754,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) gcc_assert (se->string_length); } + gfc_typespec *ts = &sym->ts; while (ref) { switch (ref->type) @@ -2740,6 +2775,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + ts = &ref->u.c.component->ts; if (first_time && is_classarray && sym->attr.dummy && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable @@ -2767,6 +2803,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) expr->symtree->name, &expr->where); break; + case REF_INQUIRY: + conv_inquiry (se, ref, expr, ts); + break; + default: gcc_unreachable (); break; @@ -4135,6 +4175,7 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, break; case REF_COMPONENT: + case REF_INQUIRY: break; case REF_SUBSTRING: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2fd83f08bbf..4f1076169a1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-11-01 Paul Thomas + + PR fortran/40196 + * gfortran.dg/inquiry_part_ref_1.f08: New test. + * gfortran.dg/inquiry_part_ref_2.f90: New test. + * gfortran.dg/inquiry_part_ref_3.f90: New test. + 2018-11-01 Paul Koning * gcc.c-torture/execute/20010904-1.c: Align 2 if pdp11. diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 new file mode 100644 index 00000000000..5ef3b480a49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Test the implementation of inquiry part references (PR40196). +! "Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)" +! +! Contributed by Tobias Burnus +! +module m + complex, target :: z + character (:), allocatable :: str + real, pointer :: r => z%re + real, pointer :: i => z%im + type :: mytype + complex :: z = ( 10.0, 11.0 ) + character(6) :: str + end type +end module + + use m + + type(mytype) :: der + integer :: j + character (len=der%str%len) :: str1 + complex, parameter :: zc = ( 99.0, 199.0 ) + REAL, parameter :: rc = zc%re + REAL, parameter :: ic = zc%im + + z = (2.0,4.0) + str = "abcd" + +! Check the pointer initializations + if (r .ne. real (z)) stop 1 + if (i .ne. imag (z)) stop 2 + +! Check the use of inquiry part_refs on lvalues and rvalues. + z%im = 4.0 * z%re + +! Check that the result is OK. + if (z%re .ne. real (z)) stop 3 + if (abs (z*im - 4.0 * real (z)) .lt. 1e-6) stop 4 + +! Check a double inquiry part_ref. + if (z%im%kind .ne. kind (z)) stop 5 + +! Test on deferred character length. + if (str%kind .ne. kind (str)) stop 6 + if (str%len .ne. len (str)) stop 7 + +! Check the use in specification expressions. + if (len (der%str) .ne. LEN (str1)) stop 8 + if (rc .ne. real (zc)) stop 9 + if (ic .ne. aimag (zc)) stop 10 + +end + diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90 new file mode 100644 index 00000000000..3c33dcca6d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! Test the implementation of inquiry part references (PR40196): +! Check the standards are correctly adhered to. +! +! Contributed by Tobias Burnus +! +program main + character(4) :: a + complex :: z + integer :: i + a%len = 2 ! { dg-error "Fortran 2003: LEN part_ref" } + i = a%kind ! { dg-error "Fortran 2003: KIND part_ref" } + print *, z%re ! { dg-error "Fortran 2008: RE or IM part_ref" } + print *, z%im ! { dg-error "Fortran 2008: RE or IM part_ref" } +end diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 new file mode 100644 index 00000000000..4e8d8a07b4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! Test the implementation of inquiry part references (PR40196): +! Check errors on invalid code. +! +! Contributed by Tobias Burnus +! +program main + type :: t + complex :: z + character(6) :: a + end type + character(4) :: a + character(:), allocatable :: b + real :: z + integer :: i + type(t) :: s + b = "abcdefg" + a%kind = 2 ! { dg-error "Assignment to a constant expression" } + b%len = 2 ! { dg-error "Assignment to a LEN or KIND part_ref" } + i = a%kind ! OK + i = b%len ! OK + print *, z%re ! { dg-error "must be applied to a COMPLEX expression" } + print *, z%im ! { dg-error "must be applied to a COMPLEX expression" } + i%re = 2.0 ! { dg-error "must be applied to a COMPLEX expression" } + print *, i%len ! { dg-error "must be applied to a CHARACTER expression" } + print *, s%kind ! { dg-error "is not a member" } + print *, s%z%kind ! OK + print *, s%a%len ! OK +end -- 2.30.2