#include "parse.h"
#include "constructor.h"
+int matching_actual_arglist = 0;
+
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
successful, sets the kind value to the correct integer. */
locus old_loc;
gfc_expr *e = NULL;
const char *msg;
- int num;
+ int num, pad;
int i;
old_loc = gfc_current_locus;
e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
&gfc_current_locus);
- e->representation.string = XCNEWVEC (char, num + 1);
+ /* Calculate padding needed to fit default integer memory. */
+ pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
+
+ e->representation.string = XCNEWVEC (char, num + pad + 1);
for (i = 0; i < num; i++)
{
- gfc_char_t c = gfc_next_char_literal (1);
+ gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
if (! gfc_wide_fits_in_byte (c))
{
gfc_error ("Invalid Hollerith constant at %L contains a "
e->representation.string[i] = (unsigned char) c;
}
- e->representation.string[num] = '\0';
- e->representation.length = num;
+ /* Now pad with blanks and end with a null char. */
+ for (i = 0; i < pad; i++)
+ e->representation.string[num + i] = ' ';
+
+ e->representation.string[num + i] = '\0';
+ e->representation.length = num + pad;
+ e->ts.u.pad = pad;
*result = e;
return MATCH_YES;
locus old_locus;
gfc_char_t c;
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (INSTRING_WARN);
*ret = 0;
if (c == '\n')
return c;
old_locus = gfc_current_locus;
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (c == delimiter)
return c;
return MATCH_YES;
head = NULL;
+ matching_actual_arglist++;
+
for (;;)
{
if (head == NULL)
}
*argp = head;
+ matching_actual_arglist--;
return MATCH_YES;
syntax:
cleanup:
gfc_free_actual_arglist (head);
gfc_current_locus = old_loc;
-
+ matching_actual_arglist--;
return MATCH_ERROR;
}
tail->type = REF_ARRAY;
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag, sym->as ? sym->as->corank : 0);
+ equiv_flag,
+ sym->ts.type == BT_CLASS
+ ? (CLASS_DATA (sym)->as
+ ? CLASS_DATA (sym)->as->corank : 0)
+ : (sym->as ? sym->as->corank : 0));
if (m != MATCH_YES)
return m;
if (component->attr.proc_pointer && ppc_arg
&& !gfc_matching_procptr_assignment)
{
+ /* Procedure pointer component call: Look for argument list. */
m = gfc_match_actual_arglist (sub_flag,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
+
+ if (m == MATCH_NO && !gfc_matching_ptr_assignment
+ && !matching_actual_arglist)
+ {
+ gfc_error ("Procedure pointer component '%s' requires an "
+ "argument list at %C", component->name);
+ return MATCH_ERROR;
+ }
+
if (m == MATCH_YES)
primary->expr_type = EXPR_PPC;
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;
sym = expr->symtree->n.sym;
attr = sym->attr;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
- for (; ref; ref = ref->next)
+ for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
attr.pointer = pointer;
attr.allocatable = allocatable;
attr.target = target;
+ attr.save = sym->attr.save;
return attr;
}
{
gfc_free (comp->name);
gfc_free_expr (comp->val);
+ gfc_free (comp);
}
/* 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)
+ if (comp_head)
{
+ gcc_assert (sym->attr.extension);
for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
{
gfc_error ("component '%s' at %L has already been set by a "
}
goto cleanup;
}
- else
- gcc_assert (!comp_head);
e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
e->ts.u.derived = sym;
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- if (sym->attr.is_protected && sym->attr.use_assoc)
- {
- gfc_error ("Assigning to PROTECTED variable at %C");
- return MATCH_ERROR;
- }
- if (sym->assoc)
- sym->assoc->variable = 1;
+ /* Everything is alright. */
break;
case FL_UNKNOWN:
case FL_PARAMETER:
if (equiv_flag)
- gfc_error ("Named constant at %C in an EQUIVALENCE");
- else
- gfc_error ("Cannot assign to a named constant at %C");
- return MATCH_ERROR;
+ {
+ gfc_error ("Named constant at %C in an EQUIVALENCE");
+ return MATCH_ERROR;
+ }
+ /* Otherwise this is checked for and an error given in the
+ variable definition context checks. */
break;
case FL_PROCEDURE:
/* Check for a nonrecursive function result variable. */
if (sym->attr.function
- && !sym->attr.external
- && sym->result == sym
- && (gfc_is_function_return_value (sym, gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns->parent)))
+ && !sym->attr.external
+ && sym->result == sym
+ && (gfc_is_function_return_value (sym, gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns->parent)))
{
/* If a function result is a derived type, then the derived
type may still have to be resolved. */
OSDN Git Service
