This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR40196 - [F03] [F08] Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Cc: mexas at bristol dot ac dot uk
- Date: Sat, 27 Oct 2018 20:03:47 +0100
- Subject: [Patch, fortran] PR40196 - [F03] [F08] Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)
I was triggered to do this by one of the comments in response to Anton
Shterenlikht's standards survey. The comment was sufficiently
inconsiderate that my first thought was not to respond. However,
curiosity got the better of me... so said the dead cat!
There is a lot of this patch but it is (more or less) straight
forward. The tricky parts were to get the logic right in
gfc_match_varspec and in expr.c. One more step on the way to real
F2002 and F2008 compliance!
Bootstraps and regtests on FC28/x86_64 - OK for trunk?
Paul
2018-10-27 Paul Thomas <pault@gcc.gnu.org>
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-10-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/40196
* gfortran.dg/inquiry_part_ref_1.f08: New test.
Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c (revision 265411)
--- gcc/fortran/dependency.c (working copy)
*************** are_identical_variables (gfc_expr *e1, g
*** 189,194 ****
--- 189,199 ----
break;
+ case REF_INQUIRY:
+ if (r1->u.i != r2->u.i)
+ return false;
+ break;
+
default:
gfc_internal_error ("are_identical_variables: Bad type");
}
*************** gfc_ref_needs_temporary_p (gfc_ref *ref)
*** 905,910 ****
--- 910,916 ----
return subarray_p;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 265411)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** show_ref (gfc_ref *p)
*** 308,313 ****
--- 308,330 ----
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");
}
*************** write_decl (gfc_typespec *ts, gfc_array_
*** 3167,3173 ****
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
!
if (rok == T_WARN)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
--- 3184,3190 ----
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
!
if (rok == T_WARN)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 265411)
--- gcc/fortran/expr.c (working copy)
*************** gfc_free_ref_list (gfc_ref *p)
*** 599,604 ****
--- 599,605 ----
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
*************** gfc_copy_ref (gfc_ref *src)
*** 756,761 ****
--- 757,766 ----
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);
*************** find_substring_ref (gfc_expr *p, gfc_exp
*** 1691,1696 ****
--- 1696,1792 ----
}
+ /* 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 (!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;
+
+ *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;
+
+ *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;
+
+ *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. */
*************** static bool
*** 1699,1705 ****
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons, *c;
! gfc_expr *newp;
gfc_ref *last_ref;
while (p->ref)
--- 1795,1801 ----
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons, *c;
! gfc_expr *newp = NULL;
gfc_ref *last_ref;
while (p->ref)
*************** simplify_const_ref (gfc_expr *p)
*** 1800,1807 ****
remove_subobject_ref (p, cons);
break;
case REF_SUBSTRING:
! if (!find_substring_ref (p, &newp))
return false;
gfc_replace_expr (p, newp);
--- 1896,1912 ----
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))
return false;
gfc_replace_expr (p, newp);
*************** simplify_const_ref (gfc_expr *p)
*** 1818,1826 ****
/* Simplify a chain of references. */
static bool
! simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
for (; ref; ref = ref->next)
{
--- 1923,1932 ----
/* Simplify a chain of references. */
static bool
! simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
{
int n;
+ gfc_expr *newp;
for (; ref; ref = ref->next)
{
*************** simplify_ref_chain (gfc_ref *ref, int ty
*** 1845,1850 ****
--- 1951,1965 ----
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;
}
*************** gfc_simplify_expr (gfc_expr *p, int type
*** 1933,1938 ****
--- 2048,2056 ----
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;
*************** gfc_simplify_expr (gfc_expr *p, int type
*** 1969,1975 ****
break;
case EXPR_SUBSTRING:
! if (!simplify_ref_chain (p->ref, type))
return false;
if (gfc_is_constant_expr (p))
--- 2087,2093 ----
break;
case EXPR_SUBSTRING:
! if (!simplify_ref_chain (p->ref, type, &p))
return false;
if (gfc_is_constant_expr (p))
*************** gfc_simplify_expr (gfc_expr *p, int type
*** 2031,2044 ****
}
/* Simplify subcomponent references. */
! if (!simplify_ref_chain (p->ref, type))
return false;
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
! if (!simplify_ref_chain (p->ref, type))
return false;
if (!simplify_constructor (p->value.constructor, type))
--- 2149,2162 ----
}
/* Simplify subcomponent references. */
! if (!simplify_ref_chain (p->ref, type, &p))
return false;
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
! if (!simplify_ref_chain (p->ref, type, &p))
return false;
if (!simplify_constructor (p->value.constructor, type))
*************** gfc_get_full_arrayspec_from_expr (gfc_ex
*** 4780,4785 ****
--- 4898,4904 ----
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
case REF_ARRAY:
*************** gfc_traverse_expr (gfc_expr *expr, gfc_s
*** 4932,4937 ****
--- 5051,5059 ----
}
break;
+ case REF_INQUIRY:
+ return true;
+
default:
gcc_unreachable ();
}
*************** gfc_is_coarray (gfc_expr *e)
*** 5286,5291 ****
--- 5408,5414 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
Index: gcc/fortran/frontend-passes.c
===================================================================
*** gcc/fortran/frontend-passes.c (revision 265412)
--- gcc/fortran/frontend-passes.c (working copy)
*************** gfc_expr_walker (gfc_expr **e, walk_expr
*** 5035,5040 ****
--- 5035,5041 ----
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
}
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 265411)
--- gcc/fortran/gfortran.h (working copy)
*************** gfc_array_ref;
*** 1936,1942 ****
before the component component. */
enum ref_type
! { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING };
typedef struct gfc_ref
{
--- 1936,1945 ----
before the component component. */
enum ref_type
! { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING, REF_INQUIRY };
!
! enum inquiry_type
! { INQUIRY_RE, INQUIRY_IM, INQUIRY_KIND, INQUIRY_LEN };
typedef struct gfc_ref
{
*************** typedef struct gfc_ref
*** 1960,1965 ****
--- 1963,1970 ----
}
ss;
+ inquiry_type i;
+
}
u;
Index: gcc/fortran/intrinsic.c
===================================================================
*** gcc/fortran/intrinsic.c (revision 265411)
--- gcc/fortran/intrinsic.c (working copy)
*************** add_subroutines (void)
*** 3316,3322 ****
*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;
--- 3316,3322 ----
*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;
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 265411)
--- gcc/fortran/match.c (working copy)
*************** gfc_match_assignment (void)
*** 1350,1355 ****
--- 1350,1363 ----
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;
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 265411)
--- gcc/fortran/module.c (working copy)
*************** DECL_MIO_NAME (procedure_type)
*** 2125,2130 ****
--- 2125,2131 ----
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
*************** static const mstring ref_types[] = {
*** 3140,3145 ****
--- 3141,3155 ----
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)
};
*************** mio_ref (gfc_ref **rp)
*** 3170,3175 ****
--- 3180,3189 ----
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 ();
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 265411)
--- gcc/fortran/primary.c (working copy)
*************** match_sym_complex_part (gfc_expr **resul
*** 1249,1255 ****
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
right parenthesis is missing. */
char c;
gfc_gobble_whitespace ();
--- 1249,1255 ----
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
right parenthesis is missing. */
char c;
gfc_gobble_whitespace ();
*************** extend_ref (gfc_expr *primary, gfc_ref *
*** 1936,1941 ****
--- 1936,1998 ----
}
+ /* 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;
+
+ switch (name[0])
+ {
+ case 'r':
+ if (strcmp (name, "re") == 0)
+ type = INQUIRY_RE;
+ else
+ return false;
+ break;
+
+ case 'i':
+ if (strcmp (name, "im") == 0)
+ type = INQUIRY_IM;
+ else
+ return false;
+ break;
+
+ case 'k':
+ if (strcmp (name, "kind") == 0)
+ type = INQUIRY_KIND;
+ else
+ return false;
+ break;
+
+ case 'l':
+ if (strcmp (name, "len") == 0)
+ type = INQUIRY_LEN;
+ else
+ return false;
+ break;
+
+ default:
+ 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
*************** gfc_match_varspec (gfc_expr *primary, in
*** 1955,1960 ****
--- 2012,2019 ----
gfc_expr *tgt_expr = NULL;
match m;
bool unknown;
+ bool inquiry;
+ locus old_loc;
char sep;
tail = NULL;
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2087,2092 ****
--- 2146,2164 ----
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);
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2118,2135 ****
}
}
else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
! && m == MATCH_YES)
{
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)
|| m != MATCH_YES)
goto check_substring;
! sym = sym->ts.u.derived;
for (;;)
{
--- 2190,2210 ----
}
}
else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
! && 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 && !inquiry)
|| m != MATCH_YES)
goto check_substring;
! if (!inquiry)
! sym = sym->ts.u.derived;
! else
! sym = NULL;
for (;;)
{
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2142,2147 ****
--- 2217,2231 ----
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
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2197,2220 ****
break;
}
! component = gfc_find_component (sym, name, false, false, &tmp);
! if (component == NULL)
return MATCH_ERROR;
! /* Extend the reference chain determined by gfc_find_component. */
if (primary->ref == NULL)
! primary->ref = tmp;
else
! {
! /* 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. */
for (tail = tmp; tail->next; tail = tail->next)
! ;
primary->ts = component->ts;
--- 2281,2369 ----
break;
}
! 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 or
! is_inquiry_ref. */
if (primary->ref == NULL)
! primary->ref = tmp;
else
! {
! /* 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. */
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_refs 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;
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2263,2273 ****
return m;
}
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
! || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
break;
! sym = component->ts.u.derived;
}
check_substring:
--- 2412,2436 ----
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)
break;
! if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
! sym = component->ts.u.derived;
}
check_substring:
*************** gfc_variable_attr (gfc_expr *expr, gfc_t
*** 2358,2363 ****
--- 2521,2527 ----
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");
*************** gfc_variable_attr (gfc_expr *expr, gfc_t
*** 2387,2392 ****
--- 2551,2561 ----
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;
+
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
*************** gfc_variable_attr (gfc_expr *expr, gfc_t
*** 2423,2429 ****
case REF_COMPONENT:
comp = ref->u.c.component;
attr = comp->attr;
! if (ts != NULL)
{
*ts = comp->ts;
/* Don't set the string length if a substring reference
--- 2592,2598 ----
case REF_COMPONENT:
comp = ref->u.c.component;
attr = comp->attr;
! if (ts != NULL && !has_inquiry_part)
{
*ts = comp->ts;
/* Don't set the string length if a substring reference
*************** gfc_variable_attr (gfc_expr *expr, gfc_t
*** 2450,2455 ****
--- 2619,2625 ----
break;
+ case REF_INQUIRY:
case REF_SUBSTRING:
allocatable = pointer = 0;
break;
*************** caf_variable_attr (gfc_expr *expr, bool
*** 2630,2635 ****
--- 2800,2806 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = pointer = 0;
break;
}
*************** gfc_convert_to_structure_constructor (gf
*** 2914,2920 ****
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] = ' ';
--- 3085,3091 ----
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] = ' ';
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 265411)
--- gcc/fortran/resolve.c (working copy)
*************** find_array_spec (gfc_expr *e)
*** 4740,4745 ****
--- 4740,4746 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
*************** gfc_resolve_substring_charlen (gfc_expr
*** 4962,4974 ****
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
{
! if (char_ref->type == REF_SUBSTRING)
! break;
if (char_ref->type == REF_COMPONENT)
ts = &char_ref->u.c.component->ts;
}
! if (!char_ref)
return;
gcc_assert (char_ref->next == NULL);
--- 4963,4975 ----
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
{
! 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 || char_ref->type == REF_INQUIRY)
return;
gcc_assert (char_ref->next == NULL);
*************** resolve_ref (gfc_expr *expr)
*** 5056,5061 ****
--- 5057,5063 ----
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
*************** resolve_ref (gfc_expr *expr)
*** 5129,5134 ****
--- 5131,5137 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
*************** resolve_deallocate_expr (gfc_expr *e)
*** 7233,7238 ****
--- 7236,7242 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
break;
}
*************** resolve_allocate_expr (gfc_expr *e, gfc_
*** 7525,7530 ****
--- 7529,7535 ----
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
pointer = 0;
break;
Index: gcc/fortran/simplify.c
===================================================================
*** gcc/fortran/simplify.c (revision 265411)
--- gcc/fortran/simplify.c (working copy)
*************** simplify_bound (gfc_expr *array, gfc_exp
*** 4182,4187 ****
--- 4182,4188 ----
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
*************** simplify_cobound (gfc_expr *array, gfc_e
*** 4324,4329 ****
--- 4325,4331 ----
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
*************** gfc_simplify_minmaxloc (gfc_expr *array,
*** 5406,5412 ****
back_val = back->value.logical;
}
!
if (sign < 0)
init_val = INT_MAX;
else if (sign > 0)
--- 5408,5414 ----
back_val = back->value.logical;
}
!
if (sign < 0)
init_val = INT_MAX;
else if (sign > 0)
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 265411)
--- gcc/fortran/trans-array.c (working copy)
*************** get_array_ctor_var_strlen (stmtblock_t *
*** 2078,2083 ****
--- 2078,2086 ----
mpz_clear (char_len);
return;
+ case REF_INQUIRY:
+ break;
+
default:
gcc_unreachable ();
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 265411)
--- gcc/fortran/trans-expr.c (working copy)
*************** conv_parent_component_references (gfc_se
*** 2510,2515 ****
--- 2510,2549 ----
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). */
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 2720,2725 ****
--- 2754,2760 ----
gcc_assert (se->string_length);
}
+ gfc_typespec *ts = &sym->ts;
while (ref)
{
switch (ref->type)
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 2740,2745 ****
--- 2775,2781 ----
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
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 2767,2772 ****
--- 2803,2812 ----
expr->symtree->name, &expr->where);
break;
+ case REF_INQUIRY:
+ conv_inquiry (se, ref, expr, ts);
+ break;
+
default:
gcc_unreachable ();
break;
*************** gfc_apply_interface_mapping_to_ref (gfc_
*** 4135,4140 ****
--- 4175,4181 ----
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
Index: gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08
===================================================================
*** gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 (nonexistent)
--- gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 (working copy)
***************
*** 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 <burnus@gcc.gnu.org>
+ !
+ 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
+