===================================================================
*************** are_identical_variables (gfc_expr *e1, g
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)
return subarray_p;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
===================================================================
*************** 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");
}
*************** write_decl (gfc_typespec *ts, gfc_array_
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
!
if (rok == T_WARN)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
!
if (rok == T_WARN)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
===================================================================
*************** gfc_free_ref_list (gfc_ref *p)
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
*************** 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);
*************** find_substring_ref (gfc_expr *p, gfc_exp
}
+ /* 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
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons, *c;
! gfc_expr *newp;
gfc_ref *last_ref;
while (p->ref)
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)
remove_subobject_ref (p, cons);
break;
case REF_SUBSTRING:
! if (!find_substring_ref (p, &newp))
return false;
gfc_replace_expr (p, newp);
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)
/* Simplify a chain of references. */
static bool
! simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
for (; ref; ref = ref->next)
{
/* 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
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
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
break;
case EXPR_SUBSTRING:
! if (!simplify_ref_chain (p->ref, type))
return false;
if (gfc_is_constant_expr (p))
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
}
/* 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))
}
/* 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
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
case REF_ARRAY:
*************** gfc_traverse_expr (gfc_expr *expr, gfc_s
}
break;
+ case REF_INQUIRY:
+ return true;
+
default:
gcc_unreachable ();
}
*************** gfc_is_coarray (gfc_expr *e)
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
===================================================================
*************** gfc_expr_walker (gfc_expr **e, walk_expr
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
}
===================================================================
*************** gfc_array_ref;
before the component component. */
enum ref_type
! { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING };
typedef struct gfc_ref
{
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
}
ss;
+ inquiry_type i;
+
}
u;
===================================================================
*************** 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;
*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;
===================================================================
*************** 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;
===================================================================
*************** 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
*************** 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)
};
*************** 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 ();
===================================================================
*************** match_sym_complex_part (gfc_expr **resul
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 ();
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 *
}
+ /* 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
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
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
}
}
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 (;;)
{
}
}
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
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
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;
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
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:
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
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
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
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
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
break;
+ case REF_INQUIRY:
case REF_SUBSTRING:
allocatable = pointer = 0;
break;
*************** caf_variable_attr (gfc_expr *expr, bool
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = pointer = 0;
break;
}
*************** gfc_convert_to_structure_constructor (gf
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] = ' ';
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] = ' ';
===================================================================
*************** find_array_spec (gfc_expr *e)
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
*************** gfc_resolve_substring_charlen (gfc_expr
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);
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)
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
*************** resolve_ref (gfc_expr *expr)
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
*************** resolve_deallocate_expr (gfc_expr *e)
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
break;
}
*************** resolve_allocate_expr (gfc_expr *e, gfc_
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
pointer = 0;
break;
===================================================================
*************** simplify_bound (gfc_expr *array, gfc_exp
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
*************** simplify_cobound (gfc_expr *array, gfc_e
continue;
case REF_SUBSTRING:
+ case REF_INQUIRY:
continue;
}
}
*************** gfc_simplify_minmaxloc (gfc_expr *array,
back_val = back->value.logical;
}
!
if (sign < 0)
init_val = INT_MAX;
else if (sign > 0)
back_val = back->value.logical;
}
!
if (sign < 0)
init_val = INT_MAX;
else if (sign > 0)
===================================================================
*************** get_array_ctor_var_strlen (stmtblock_t *
mpz_clear (char_len);
return;
+ case REF_INQUIRY:
+ break;
+
default:
gcc_unreachable ();
}
===================================================================
*************** conv_parent_component_references (gfc_se
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
gcc_assert (se->string_length);
}
+ gfc_typespec *ts = &sym->ts;
while (ref)
{
switch (ref->type)
*************** gfc_conv_variable (gfc_se * se, gfc_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
*************** gfc_conv_variable (gfc_se * se, gfc_expr
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_
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
===================================================================
***************
+ ! { 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
+
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.