/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "match.h"
#include "parse.h"
#include "toplev.h"
+#include "constructor.h"
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
if (sym->attr.flavor != FL_PARAMETER)
return MATCH_NO;
+ if (sym->value == NULL)
+ return MATCH_NO;
+
p = gfc_extract_int (sym->value, kind);
if (p != NULL)
return MATCH_NO;
else
{
gfc_free_expr (e);
- e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
- &gfc_current_locus);
+ e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
e->representation.string = XCNEWVEC (char, num + 1);
ref->type = REF_SUBSTRING;
if (start == NULL)
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
ref->u.ss.start = start;
if (end == NULL && cl)
end = gfc_copy_expr (cl->length);
if (!ISALNUM (c)
&& c != '_'
- && (gfc_option.flag_dollar_ok && c != '$'))
+ && (c != '$' || !gfc_option.flag_dollar_ok))
break;
*name++ = c;
if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
goto no_match;
-
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
+ e = gfc_get_character_expr (kind, &start_locus, NULL, length);
e->ref = NULL;
- e->ts.type = BT_CHARACTER;
- e->ts.kind = kind;
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = start_locus;
-
- e->value.character.string = p = gfc_get_wide_string (length + 1);
- e->value.character.length = length;
gfc_current_locus = start_locus;
gfc_next_char (); /* Skip delimiter */
warn_ampersand = gfc_option.warn_ampersand;
gfc_option.warn_ampersand = 0;
+ p = e->value.character.string;
for (i = 0; i < length; i++)
{
c = next_string_char (delimiter, &ret);
return MATCH_ERROR;
}
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = i;
- e->ts.type = BT_LOGICAL;
- e->ts.kind = kind;
+ e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = gfc_current_locus;
*result = e;
return MATCH_YES;
}
+/* This checks if a symbol is the return value of an encompassing function.
+ Function nesting can be maximally two levels deep, but we may have
+ additional local namespaces like BLOCK etc. */
+
+bool
+gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
+{
+ if (!sym->attr.function || (sym->result != sym))
+ return false;
+ while (ns)
+ {
+ if (ns->proc_name == sym)
+ return true;
+ ns = ns->parent;
+ }
+ return false;
+}
+
+
/* Match a single actual argument value. An actual argument is
usually an expression, but can also be a procedure name. If the
argument is a single name, it is not always possible to tell
have a function argument. */
if (symtree == NULL)
{
- gfc_get_sym_tree (name, NULL, &symtree);
+ gfc_get_sym_tree (name, NULL, &symtree, false);
gfc_set_sym_referenced (symtree->n.sym);
}
else
is being defined, then we have a variable. */
if (sym->attr.function && sym->result == sym)
{
- if (gfc_current_ns->proc_name == sym
- || (gfc_current_ns->parent != NULL
- && gfc_current_ns->parent->proc_name == sym))
+ if (gfc_is_function_return_value (sym, gfc_current_ns))
break;
if (sym->attr.entry
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
statement. sub_flag tells whether we expect a type-bound procedure found
- to be a subroutine as part of CALL or a FUNCTION. */
+ to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+ components, 'ppc_arg' determines whether the PPC may be called (with an
+ argument list), or whether it may just be referred to as a pointer. */
match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+ bool ppc_arg)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
tail = NULL;
gfc_gobble_whitespace ();
- if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension)
+
+ if (gfc_peek_ascii_char () == '[')
+ {
+ if (sym->attr.dimension)
+ {
+ gfc_error ("Array section designator, e.g. '(:)', is required "
+ "besides the coarray designator '[...]' at %C");
+ return MATCH_ERROR;
+ }
+ if (!sym->attr.codimension)
+ {
+ gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+ sym->name);
+ return MATCH_ERROR;
+ }
+ }
+
+ if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ || gfc_peek_ascii_char () == '[' || sym->attr.codimension
+ || (sym->attr.dimension && !sym->attr.proc_pointer
+ && !gfc_is_proc_ptr_comp (primary, NULL)
+ && !(gfc_matching_procptr_assignment
+ && sym->attr.flavor == FL_PROCEDURE))
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.dimension))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
tail->type = REF_ARRAY;
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag);
+ equiv_flag, sym->as ? sym->as->corank : 0);
if (m != MATCH_YES)
return m;
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
if (m != MATCH_YES)
return m;
}
return MATCH_YES;
if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
- if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
+ if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+ || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
- sym = sym->ts.derived;
+ sym = sym->ts.u.derived;
for (;;)
{
if (m != MATCH_YES)
return MATCH_ERROR;
- tbp = gfc_find_typebound_proc (sym, &t, name, false);
+ if (sym->f2k_derived)
+ tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
+ else
+ tbp = NULL;
+
if (tbp)
{
gfc_symbol* tbp_sym;
gcc_assert (!tail || !tail->next);
gcc_assert (primary->expr_type == EXPR_VARIABLE);
- if (tbp->typebound->is_generic)
+ if (tbp->n.tb->is_generic)
tbp_sym = NULL;
else
- tbp_sym = tbp->typebound->u.specific->n.sym;
+ tbp_sym = tbp->n.tb->u.specific->n.sym;
primary->expr_type = EXPR_COMPCALL;
- primary->value.compcall.tbp = tbp->typebound;
+ primary->value.compcall.tbp = tbp->n.tb;
primary->value.compcall.name = tbp->name;
+ primary->value.compcall.ignore_pass = 0;
+ primary->value.compcall.assign = 0;
+ primary->value.compcall.base_object = NULL;
gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;
- m = gfc_match_actual_arglist (tbp->typebound->subroutine,
+ m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
}
}
- gfc_set_sym_referenced (tbp->n.sym);
-
break;
}
primary->ts = component->ts;
- if (component->as != NULL)
+ if (component->attr.proc_pointer && ppc_arg
+ && !gfc_matching_procptr_assignment)
+ {
+ m = gfc_match_actual_arglist (sub_flag,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ primary->expr_type = EXPR_PPC;
+
+ break;
+ }
+
+ if (component->as != NULL && !component->attr.proc_pointer)
{
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+ component->as->corank);
+ if (m != MATCH_YES)
+ return m;
+ }
+ else if (component->ts.type == BT_CLASS
+ && component->ts.u.derived->components->as != NULL
+ && !component->attr.proc_pointer)
+ {
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
+ m = gfc_match_array_ref (&tail->u.ar,
+ component->ts.u.derived->components->as,
+ equiv_flag,
+ component->ts.u.derived->components->as->corank);
if (m != MATCH_YES)
return m;
}
- if (component->ts.type != BT_DERIVED
+ if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|| gfc_match_char ('%') != MATCH_YES)
break;
- sym = component->ts.derived;
+ sym = component->ts.u.derived;
}
check_substring:
unknown = false;
- if (primary->ts.type == BT_UNKNOWN)
+ if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
{
- if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+ if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
{
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
if (primary->ts.type == BT_CHARACTER)
{
- switch (match_substring (primary->ts.cl, equiv_flag, &substring))
+ switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
{
case MATCH_YES:
if (tail == NULL)
primary->expr_type = EXPR_SUBSTRING;
if (substring)
- primary->ts.cl = NULL;
+ primary->ts.u.cl = NULL;
break;
}
}
+ /* F2008, C727. */
+ if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+ {
+ gfc_error ("Coindexed procedure-pointer component at %C");
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
- if (expr->expr_type != EXPR_VARIABLE)
+ if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
ref = expr->ref;
- attr = expr->symtree->n.sym->attr;
+ sym = expr->symtree->n.sym;
+ attr = sym->attr;
- dimension = attr.dimension;
- pointer = attr.pointer;
- allocatable = attr.allocatable;
+ if (sym->ts.type == BT_CLASS)
+ {
+ dimension = sym->ts.u.derived->components->attr.dimension;
+ pointer = sym->ts.u.derived->components->attr.pointer;
+ allocatable = sym->ts.u.derived->components->attr.allocatable;
+ }
+ else
+ {
+ dimension = attr.dimension;
+ pointer = attr.pointer;
+ allocatable = attr.allocatable;
+ }
target = attr.target;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
- *ts = expr->symtree->n.sym->ts;
+ *ts = sym->ts;
for (; ref; ref = ref->next)
switch (ref->type)
break;
case AR_ELEMENT:
- allocatable = pointer = 0;
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0)
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
break;
case REF_COMPONENT:
- attr = ref->u.c.component->attr;
+ comp = ref->u.c.component;
+ attr = comp->attr;
if (ts != NULL)
{
- *ts = ref->u.c.component->ts;
+ *ts = comp->ts;
/* Don't set the string length if a substring reference
follows. */
if (ts->type == BT_CHARACTER
&& ref->next && ref->next->type == REF_SUBSTRING)
- ts->cl = NULL;
+ ts->u.cl = NULL;
}
- pointer = ref->u.c.component->attr.pointer;
- allocatable = ref->u.c.component->attr.allocatable;
- if (pointer)
+ if (comp->ts.type == BT_CLASS)
+ {
+ pointer = comp->ts.u.derived->components->attr.pointer;
+ allocatable = comp->ts.u.derived->components->attr.allocatable;
+ }
+ else
+ {
+ pointer = comp->attr.pointer;
+ allocatable = comp->attr.allocatable;
+ }
+ if (pointer || attr.proc_pointer)
target = 1;
break;
gfc_clear_attr (&attr);
if (e->value.function.esym != NULL)
- attr = e->value.function.esym->result->attr;
+ {
+ gfc_symbol *sym = e->value.function.esym->result;
+ attr = sym->attr;
+ if (sym->ts.type == BT_CLASS)
+ {
+ attr.dimension = sym->ts.u.derived->components->attr.dimension;
+ attr.pointer = sym->ts.u.derived->components->attr.pointer;
+ attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
+ }
+ }
+ else
+ attr = gfc_variable_attr (e, NULL);
/* TODO: NULL() returns pointers. May have to take care of this
here. */
for components without explicit value given. */
static gfc_try
build_actual_constructor (gfc_structure_ctor_component **comp_head,
- gfc_constructor **ctor_head, gfc_symbol *sym)
+ gfc_constructor_base *ctor_head, gfc_symbol *sym)
{
gfc_structure_ctor_component *comp_iter;
- gfc_constructor *ctor_tail = NULL;
gfc_component *comp;
for (comp = sym->components; comp; comp = comp->next)
a value expression for the parent derived type and calling self. */
if (!comp_iter && comp == sym->components && sym->attr.extension)
{
- value = gfc_get_expr ();
- value->expr_type = EXPR_STRUCTURE;
- value->value.constructor = NULL;
+ value = gfc_get_structure_constructor_expr (comp->ts.type,
+ comp->ts.kind,
+ &gfc_current_locus);
value->ts = comp->ts;
- value->where = gfc_current_locus;
if (build_actual_constructor (comp_head, &value->value.constructor,
- comp->ts.derived) == FAILURE)
+ comp->ts.u.derived) == FAILURE)
{
gfc_free_expr (value);
return FAILURE;
}
- *ctor_head = ctor_tail = gfc_get_constructor ();
- ctor_tail->expr = value;
+
+ gfc_constructor_append_expr (ctor_head, value, NULL);
continue;
}
value = comp_iter->val;
/* Add the value to the constructor chain built. */
- if (ctor_tail)
- {
- ctor_tail->next = gfc_get_constructor ();
- ctor_tail = ctor_tail->next;
- }
- else
- *ctor_head = ctor_tail = gfc_get_constructor ();
- gcc_assert (value);
- ctor_tail->expr = value;
+ gfc_constructor_append_expr (ctor_head, value, NULL);
/* Remove the entry from the component list. We don't want the expression
value to be free'd, so set it to NULL. */
bool parent)
{
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
- gfc_constructor *ctor_head, *ctor_tail;
+ gfc_constructor_base ctor_head = NULL;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
locus where;
const char* last_name = NULL;
comp_tail = comp_head = NULL;
- ctor_head = ctor_tail = NULL;
if (!parent && gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component '%s' in "
+ "structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+
+
/* If not explicitly a parent constructor, gather up the components
and build one. */
if (comp && comp == sym->components
&& sym->attr.extension
&& (comp_tail->val->ts.type != BT_DERIVED
||
- comp_tail->val->ts.derived != this_comp->ts.derived))
+ comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
{
gfc_current_locus = where;
gfc_free_expr (comp_tail->val);
comp_tail->val = NULL;
- m = gfc_match_structure_constructor (comp->ts.derived,
+ m = gfc_match_structure_constructor (comp->ts.u.derived,
&comp_tail->val, true);
if (m == MATCH_NO)
goto syntax;
else
gcc_assert (!comp_head);
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_STRUCTURE;
-
- e->ts.type = BT_DERIVED;
- e->ts.derived = sym;
- e->where = where;
-
+ e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
+ e->ts.u.derived = sym;
e->value.constructor = ctor_head;
*result = e;
gfc_free_structure_ctor_component (comp_iter);
comp_iter = next;
}
- gfc_free_constructor (ctor_head);
+ gfc_constructor_free (ctor_head);
return MATCH_ERROR;
}
&& !(*sym)->attr.use_assoc)
{
int i;
- i = gfc_get_sym_tree ((*sym)->name, NULL, st);
+ i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
if (i)
return MATCH_ERROR;
*sym = (*st)->n.sym;
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
&& !gfc_current_ns->has_import_set)
- i = gfc_get_sym_tree (name, NULL, &symtree);
+ i = gfc_get_sym_tree (name, NULL, &symtree, false);
else
i = gfc_get_ha_sym_tree (name, &symtree);
return MATCH_ERROR;
}
- if (gfc_current_ns->proc_name == sym
- || (gfc_current_ns->parent != NULL
- && gfc_current_ns->parent->proc_name == sym))
+ if (gfc_is_function_return_value (sym, gfc_current_ns))
goto variable;
if (sym->attr.entry
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
case FL_PARAMETER:
}
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
if (gfc_matching_procptr_assignment)
{
gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () == '(')
+ if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
/* Parse functions returning a procptr. */
goto function0;
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
/*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
implicit_char = false;
if (sym->ts.type == BT_UNKNOWN)
{
- ts = gfc_get_default_type (sym,NULL);
+ ts = gfc_get_default_type (sym->name, NULL);
if (ts->type == BT_CHARACTER)
implicit_char = true;
}
that we're not sure is a variable yet. */
if ((implicit_char || sym->ts.type == BT_CHARACTER)
- && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
+ && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
{
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
if (e->ref)
- e->ts.cl = NULL;
+ e->ts.u.cl = NULL;
m = MATCH_YES;
break;
}
/* Give up, assume we have a function. */
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
sym = symtree->n.sym;
e->expr_type = EXPR_FUNCTION;
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
if (m == MATCH_NO)
m = MATCH_YES;
break;
generic_function:
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
if (sym->attr.function
&& !sym->attr.external
&& sym->result == sym
- && ((sym == gfc_current_ns->proc_name
- && sym == gfc_current_ns->proc_name->result)
- || (gfc_current_ns->parent
- && sym == gfc_current_ns->parent->proc_name->result)
+ && (gfc_is_function_return_value (sym, gfc_current_ns)
|| (sym->attr.entry
&& sym->ns == gfc_current_ns)
|| (sym->attr.entry
type may still have to be resolved. */
if (sym->ts.type == BT_DERIVED
- && gfc_use_derived (sym->ts.derived) == NULL)
+ && gfc_use_derived (sym->ts.u.derived) == NULL)
return MATCH_ERROR;
break;
}
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, implicit_ns);
}
expr->where = where;
/* Now see if we have to do more. */
- m = gfc_match_varspec (expr, equiv_flag, false);
+ m = gfc_match_varspec (expr, equiv_flag, false, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
OSDN Git Service
