}
-/* Used by match_varspec() to extend the reference list by one
+/* Used by gfc_match_varspec() to extend the reference list by one
element. */
static gfc_ref *
/* 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
- statement. */
+ statement. sub_flag tells whether we expect a type-bound procedure found
+ to be a subroutine as part of CALL or a FUNCTION. */
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
if (equiv_flag)
return MATCH_YES;
+ if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
+ && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ gfc_set_default_type (sym, 0, sym->ns);
+
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
for (;;)
{
+ gfc_try t;
+ gfc_symtree *tbp;
+
m = gfc_match_name (name);
if (m == MATCH_NO)
gfc_error ("Expected structure component name at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
- component = gfc_find_component (sym, name);
+ tbp = gfc_find_typebound_proc (sym, &t, name, false);
+ if (tbp)
+ {
+ gfc_symbol* tbp_sym;
+
+ if (t == FAILURE)
+ return MATCH_ERROR;
+
+ gcc_assert (!tail || !tail->next);
+ gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+ if (tbp->typebound->is_generic)
+ tbp_sym = NULL;
+ else
+ tbp_sym = tbp->typebound->u.specific->n.sym;
+
+ primary->expr_type = EXPR_COMPCALL;
+ primary->value.compcall.tbp = tbp->typebound;
+ primary->value.compcall.name = tbp->name;
+ gcc_assert (primary->symtree->n.sym->attr.referenced);
+ if (tbp_sym)
+ primary->ts = tbp_sym->ts;
+
+ m = gfc_match_actual_arglist (tbp->typebound->subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ if (sub_flag)
+ primary->value.compcall.actual = NULL;
+ else
+ {
+ gfc_error ("Expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_set_sym_referenced (tbp->n.sym);
+
+ break;
+ }
+
+ component = gfc_find_component (sym, name, false, false);
if (component == NULL)
return MATCH_ERROR;
case MATCH_NO:
if (unknown)
- gfc_clear_ts (&primary->ts);
+ {
+ gfc_clear_ts (&primary->ts);
+ gfc_clear_ts (&sym->ts);
+ }
break;
case MATCH_ERROR:
}
match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
+ bool parent)
{
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
gfc_constructor *ctor_head, *ctor_tail;
where = gfc_current_locus;
- gfc_find_component (sym, NULL);
+ gfc_find_component (sym, NULL, false, true);
+
+ /* Check that we're not about to construct an ABSTRACT type. */
+ if (!parent && sym->attr.abstract)
+ {
+ gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
+ return MATCH_ERROR;
+ }
/* Match the component list and store it in a list together with the
corresponding component names. Check for empty argument list first. */
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
}
- /* Find the current component in the structure definition and check its
- access is not private. */
+ /* Find the current component in the structure definition and check
+ its access is not private. */
if (comp)
- this_comp = gfc_find_component (sym, comp->name);
+ this_comp = gfc_find_component (sym, comp->name, false, false);
else
{
- this_comp = gfc_find_component (sym, (const char *)comp_tail->name);
+ this_comp = gfc_find_component (sym,
+ (const char *)comp_tail->name,
+ false, false);
comp = NULL; /* Reset needed! */
}
{
gfc_current_locus = where;
gfc_free_expr (comp_tail->val);
+ comp_tail->val = NULL;
m = gfc_match_structure_constructor (comp->ts.derived,
&comp_tail->val, true);
{
case FL_VARIABLE:
variable:
- if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, sym->ns);
-
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
break;
case FL_PARAMETER:
}
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
break;
}
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
break;
}
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
break;
}
break;
}
- /*FIXME:??? match_varspec does set this for us: */
+ /*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
break;
}
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
if (m == MATCH_NO)
m = MATCH_YES;
expr->where = where;
/* Now see if we have to do more. */
- m = match_varspec (expr, equiv_flag);
+ m = gfc_match_varspec (expr, equiv_flag, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
OSDN Git Service
