2018-11-01 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-11-01 Paul Thomas <pault@gcc.gnu.org>
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
+2018-11-01 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-11-01 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/46020
break;
+ case REF_INQUIRY:
+ if (r1->u.i != r2->u.i)
+ return false;
+ break;
+
default:
gfc_internal_error ("are_identical_variables: Bad type");
}
return subarray_p;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
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");
}
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
-
+
if (rok == T_WARN)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
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);
}
+/* 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. */
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons, *c;
- gfc_expr *newp;
+ gfc_expr *newp = NULL;
gfc_ref *last_ref;
while (p->ref)
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);
/* 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)
{
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;
}
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;
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))
}
/* 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))
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
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
case REF_ARRAY:
}
break;
+ case REF_INQUIRY:
+ return true;
+
default:
gcc_unreachable ();
}
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
}
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
{
}
ss;
+ inquiry_type i;
+
}
u;
*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;
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;
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
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_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 ();
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 ();
}
+/* 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
gfc_expr *tgt_expr = NULL;
match m;
bool unknown;
+ bool inquiry;
+ locus old_loc;
char sep;
tail = NULL;
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);
}
}
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 (;;)
{
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
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;
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:
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");
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)
{
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
break;
+ case REF_INQUIRY:
case REF_SUBSTRING:
allocatable = pointer = 0;
break;
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = pointer = 0;
break;
}
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] = ' ';
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
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);
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
break;
}
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
pointer = 0;
break;
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
back_val = back->value.logical;
}
-
+
if (sign < 0)
init_val = INT_MAX;
else if (sign > 0)
mpz_clear (char_len);
return;
+ case REF_INQUIRY:
+ break;
+
default:
gcc_unreachable ();
}
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). */
gcc_assert (se->string_length);
}
+ gfc_typespec *ts = &sym->ts;
while (ref)
{
switch (ref->type)
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
expr->symtree->name, &expr->where);
break;
+ case REF_INQUIRY:
+ conv_inquiry (se, ref, expr, ts);
+ break;
+
default:
gcc_unreachable ();
break;
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
+2018-11-01 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <ni1d@arrl.net>
* gcc.c-torture/execute/20010904-1.c: Align 2 if pdp11.
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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 <burnus@gcc.gnu.org>
+!
+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
--- /dev/null
+! { dg-do compile }
+!
+! Test the implementation of inquiry part references (PR40196):
+! Check errors on invalid code.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+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
projects / gcc.git / commitdiff