if (length == -1)
return MATCH_NO;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
gfc_gobble_whitespace ();
e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
&gfc_current_locus);
- e->representation.string = gfc_getmem (num + 1);
+ e->representation.string = XCNEWVEC (char, num + 1);
for (i = 0; i < num; i++)
{
gfc_current_locus = old_loc;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
match_digits (0, radix, buffer);
gfc_current_locus = old_loc;
gfc_gobble_whitespace ();
- buffer = alloca (count + 1);
+ buffer = (char *) alloca (count + 1);
memset (buffer, '\0', count + 1);
p = buffer;
{
c = next_string_char (delimiter, &ret);
- if (!gfc_wide_fits_in_byte (c))
+ if (!gfc_check_character_range (c, kind))
{
- gfc_error ("Unimplemented feature at %C: gfortran currently only "
- "supports character strings with one-byte characters");
+ gfc_error ("Character '%s' in string at %C is not representable "
+ "in character kind %d", gfc_print_wide_char (c), kind);
return MATCH_ERROR;
}
}
-/* 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:
break;
case REF_COMPONENT:
- gfc_get_component_attr (&attr, ref->u.c.component);
+ attr = ref->u.c.component->attr;
if (ts != NULL)
{
*ts = ref->u.c.component->ts;
ts->cl = NULL;
}
- pointer = ref->u.c.component->pointer;
- allocatable = ref->u.c.component->allocatable;
+ pointer = ref->u.c.component->attr.pointer;
+ allocatable = ref->u.c.component->attr.allocatable;
if (pointer)
target = 1;
/* Match a structure constructor. The initial symbol has already been
seen. */
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+typedef struct gfc_structure_ctor_component
{
- gfc_constructor *head, *tail;
- gfc_component *comp;
- gfc_expr *e;
+ char* name;
+ gfc_expr* val;
locus where;
- match m;
- bool private_comp = false;
+ struct gfc_structure_ctor_component* next;
+}
+gfc_structure_ctor_component;
- head = tail = NULL;
+#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
+static void
+gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
+{
+ gfc_free (comp->name);
+ gfc_free_expr (comp->val);
+}
- where = gfc_current_locus;
- gfc_find_component (sym, NULL);
+/* Translate the component list into the actual constructor by sorting it in
+ the order required; this also checks along the way that each and every
+ component actually has an initializer and handles default initializers
+ 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_structure_ctor_component *comp_iter;
+ gfc_constructor *ctor_tail = NULL;
+ gfc_component *comp;
for (comp = sym->components; comp; comp = comp->next)
{
- if (comp->access == ACCESS_PRIVATE)
+ gfc_structure_ctor_component **next_ptr;
+ gfc_expr *value = NULL;
+
+ /* Try to find the initializer for the current component by name. */
+ next_ptr = comp_head;
+ for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
{
- private_comp = true;
- break;
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
}
- if (head == NULL)
- tail = head = gfc_get_constructor ();
- else
+
+ /* If an extension, try building the parent derived type by building
+ a value expression for the parent derived type and calling self. */
+ if (!comp_iter && comp == sym->components && sym->attr.extension)
{
- tail->next = gfc_get_constructor ();
- tail = tail->next;
+ value = gfc_get_expr ();
+ value->expr_type = EXPR_STRUCTURE;
+ value->value.constructor = NULL;
+ value->ts = comp->ts;
+ value->where = gfc_current_locus;
+
+ if (build_actual_constructor (comp_head, &value->value.constructor,
+ comp->ts.derived) == FAILURE)
+ {
+ gfc_free_expr (value);
+ return FAILURE;
+ }
+ *ctor_head = ctor_tail = gfc_get_constructor ();
+ ctor_tail->expr = value;
+ continue;
}
- m = gfc_match_expr (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
{
- if (comp->next == NULL)
+ if (comp->initializer)
{
- gfc_error ("Too many components in structure constructor at %C");
- goto cleanup;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with missing optional arguments"
+ " at %C") == FAILURE)
+ return FAILURE;
+ value = gfc_copy_expr (comp->initializer);
}
+ else
+ {
+ gfc_error ("No initializer for component '%s' given in the"
+ " structure constructor at %C!", comp->name);
+ return FAILURE;
+ }
+ }
+ else
+ value = comp_iter->val;
- continue;
+ /* 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;
- break;
+ /* Remove the entry from the component list. We don't want the expression
+ value to be free'd, so set it to NULL. */
+ if (comp_iter)
+ {
+ *next_ptr = comp_iter->next;
+ comp_iter->val = NULL;
+ gfc_free_structure_ctor_component (comp_iter);
+ }
}
+ return SUCCESS;
+}
+
+match
+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;
+ gfc_component *comp; /* Is set NULL when named component is first seen */
+ gfc_expr *e;
+ locus where;
+ match m;
+ const char* last_name = NULL;
+
+ comp_tail = comp_head = NULL;
+ ctor_head = ctor_tail = NULL;
+
+ if (!parent && gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ where = gfc_current_locus;
- if (sym->attr.use_assoc
- && (sym->component_access == ACCESS_PRIVATE || private_comp))
+ 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 ("Structure constructor for '%s' at %C has PRIVATE "
- "components", sym->name);
- goto cleanup;
+ 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. */
if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ {
+ comp = sym->components;
+ do
+ {
+ gfc_component *this_comp = NULL;
+
+ if (!comp_head)
+ comp_tail = comp_head = gfc_get_structure_ctor_component ();
+ else
+ {
+ comp_tail->next = gfc_get_structure_ctor_component ();
+ comp_tail = comp_tail->next;
+ }
+ comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
+ comp_tail->val = NULL;
+ comp_tail->where = gfc_current_locus;
+
+ /* Try matching a component name. */
+ if (gfc_match_name (comp_tail->name) == MATCH_YES
+ && gfc_match_char ('=') == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with named arguments at %C")
+ == FAILURE)
+ goto cleanup;
+
+ last_name = comp_tail->name;
+ comp = NULL;
+ }
+ else
+ {
+ /* Components without name are not allowed after the first named
+ component initializer! */
+ if (!comp)
+ {
+ if (last_name)
+ gfc_error ("Component initializer without name after"
+ " component named %s at %C!", last_name);
+ else if (!parent)
+ gfc_error ("Too many components in structure constructor at"
+ " %C!");
+ goto cleanup;
+ }
+
+ gfc_current_locus = comp_tail->where;
+ 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. */
+ if (comp)
+ this_comp = gfc_find_component (sym, comp->name, false, false);
+ else
+ {
+ this_comp = gfc_find_component (sym,
+ (const char *)comp_tail->name,
+ false, false);
+ comp = NULL; /* Reset needed! */
+ }
+
+ /* Here we can check if a component name is given which does not
+ correspond to any component of the defined structure. */
+ if (!this_comp)
+ goto cleanup;
+
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
+ {
+ gcc_assert (comp_iter);
+ if (!strcmp (comp_iter->name, comp_tail->name))
+ {
+ gfc_error ("Component '%s' is initialized twice in the"
+ " structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+ }
+
+ /* Match the current initializer expression. */
+ m = gfc_match_expr (&comp_tail->val);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
- if (comp && comp->next != NULL)
+ /* 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))
+ {
+ 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);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+
+ if (comp)
+ comp = comp->next;
+
+ if (parent && !comp)
+ break;
+ }
+
+ while (gfc_match_char (',') == MATCH_YES);
+
+ if (!parent && gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
+
+ /* No component should be left, as this should have caused an error in the
+ loop constructing the component-list (name that does not correspond to any
+ component in the structure definition). */
+ if (comp_head && sym->attr.extension)
{
- gfc_error ("Too few components in structure constructor at %C");
+ for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ gfc_error ("component '%s' at %L has already been set by a "
+ "parent derived type constructor", comp_iter->name,
+ &comp_iter->where);
+ }
goto cleanup;
}
+ else
+ gcc_assert (!comp_head);
e = gfc_get_expr ();
e->ts.derived = sym;
e->where = where;
- e->value.constructor = head;
+ e->value.constructor = ctor_head;
*result = e;
return MATCH_YES;
gfc_error ("Syntax error in structure constructor at %C");
cleanup:
- gfc_free_constructor (head);
+ for (comp_iter = comp_head; comp_iter; )
+ {
+ gfc_structure_ctor_component *next = comp_iter->next;
+ gfc_free_structure_ctor_component (comp_iter);
+ comp_iter = next;
+ }
+ gfc_free_constructor (ctor_head);
return MATCH_ERROR;
}
}
}
+ if (gfc_matching_procptr_assignment)
+ goto procptr0;
+
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
goto function0;
{
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;
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e, false);
break;
/* If we're here, then the name is known to be the name of a
procedure, yet it is not sure to be the name of a function. */
case FL_PROCEDURE:
+
+ /* Procedure Pointer Assignments. */
+ procptr0:
+ if (gfc_matching_procptr_assignment)
+ {
+ gfc_gobble_whitespace ();
+ if (sym->attr.function && gfc_peek_ascii_char () == '(')
+ /* Parse functions returning a procptr. */
+ goto function0;
+
+ if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+ if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
+ || gfc_is_intrinsic (sym, 1, gfc_current_locus))
+ sym->attr.intrinsic = 1;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ m = gfc_match_varspec (e, 0, false);
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
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;
}
-/* Match a variable, ie something that can be assigned to. This
+/* Match a variable, i.e. something that can be assigned to. This
starts as a symbol, can be a structure component or an array
reference. It can be a function if the function doesn't have a
separate RESULT variable. If the symbol has not been previously
we force the changed_symbols mechanism to work by setting
host_flag to 0. This prevents valid symbols that have the name
of keywords, such as 'end', being turned into variables by
- failed matching to assignments for, eg., END INTERFACE. */
+ failed matching to assignments for, e.g., END INTERFACE. */
if (gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- if (sym->attr.protected && sym->attr.use_assoc)
+ if (sym->attr.is_protected && sym->attr.use_assoc)
{
gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR;
break;
}
+ if (sym->attr.proc_pointer)
+ break;
+
/* Fall through to error */
default:
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
