out what is going on. */
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name);
- name[GFC_MAX_SYMBOL_LEN] = '\0';
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL);
gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
+ gfc_symbol *sym;
+ gfc_typespec *ts, *fts;
+
gfc_add_function (&proc->attr, proc->name, NULL);
- gfc_internal_error ("TODO: Functions with alternate entry points");
+ proc->result = proc;
+ fts = &ns->entries->sym->result->ts;
+ if (fts->type == BT_UNKNOWN)
+ fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+ for (el = ns->entries->next; el; el = el->next)
+ {
+ ts = &el->sym->result->ts;
+ if (ts->type == BT_UNKNOWN)
+ ts = gfc_get_default_type (el->sym->result, NULL);
+ if (! gfc_compare_types (ts, fts)
+ || (el->sym->result->attr.dimension
+ != ns->entries->sym->result->attr.dimension)
+ || (el->sym->result->attr.pointer
+ != ns->entries->sym->result->attr.pointer))
+ break;
+ }
+
+ if (el == NULL)
+ {
+ sym = ns->entries->sym->result;
+ /* All result types the same. */
+ proc->ts = *fts;
+ if (sym->attr.dimension)
+ gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
+ if (sym->attr.pointer)
+ gfc_add_pointer (&proc->attr, NULL);
+ }
+ else
+ {
+ /* Otherwise the result will be passed through an union by
+ reference. */
+ proc->attr.mixed_entry_master = 1;
+ for (el = ns->entries; el; el = el->next)
+ {
+ sym = el->sym->result;
+ if (sym->attr.dimension)
+ gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else if (sym->attr.pointer)
+ gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else
+ {
+ ts = &sym->ts;
+ if (ts->type == BT_UNKNOWN)
+ ts = gfc_get_default_type (sym, NULL);
+ switch (ts->type)
+ {
+ case BT_INTEGER:
+ if (ts->kind == gfc_default_integer_kind)
+ sym = NULL;
+ break;
+ case BT_REAL:
+ if (ts->kind == gfc_default_real_kind
+ || ts->kind == gfc_default_double_kind)
+ sym = NULL;
+ break;
+ case BT_COMPLEX:
+ if (ts->kind == gfc_default_complex_kind)
+ sym = NULL;
+ break;
+ case BT_LOGICAL:
+ if (ts->kind == gfc_default_logical_kind)
+ sym = NULL;
+ break;
+ default:
+ break;
+ }
+ if (sym)
+ gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ }
+ }
+ }
}
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
return 1;
- if (a.allocatable || a.dimension || a.external || a.intrinsic
+ if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
|| sym->attr.external)
{
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Statement function '%s' at %L is not allowed as an "
+ "actual argument", sym->name, &e->where);
+ }
+
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
}
-/* Figure out if if a function reference is pure or not. Also sets the name
- of the function for a potential error message. Returns nonzero if the
+/* Figure out if a function reference is pure or not. Also set the name
+ of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
static int
return t;
}
+/* Compare the shapes of two arrays that have non-NULL shapes. If both
+ op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
+ match. If both op1->shape and op2->shape are non-NULL return FAILURE
+ if their shapes do not match. If either op1->shape or op2->shape is
+ NULL, return SUCCESS. */
+
+static try
+compare_shapes (gfc_expr * op1, gfc_expr * op2)
+{
+ try t;
+ int i;
+
+ t = SUCCESS;
+
+ if (op1->shape != NULL && op2->shape != NULL)
+ {
+ for (i = 0; i < op1->rank; i++)
+ {
+ if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
+ {
+ gfc_error ("Shapes for operands at %L and %L are not conformable",
+ &op1->where, &op2->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
+ return t;
+}
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
if (op1->rank == op2->rank)
{
e->rank = op1->rank;
-
if (e->shape == NULL)
+ {
+ t = compare_shapes(op1, op2);
+ if (t == FAILURE)
+ e->shape = NULL;
+ else
e->shape = gfc_copy_shape (op1->shape, op1->rank);
-
+ }
}
else
{
return t;
bad_op:
+
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
gfc_error (msg, &e->where);
+
return FAILURE;
}
if (gfc_resolve_expr (index) == FAILURE)
return FAILURE;
- if (index->ts.type != BT_INTEGER)
+ if (check_scalar && index->rank != 0)
{
- gfc_error ("Array index at %L must be of INTEGER type", &index->where);
+ gfc_error ("Array index at %L must be scalar", &index->where);
return FAILURE;
}
- if (check_scalar && index->rank != 0)
+ if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
- gfc_error ("Array index at %L must be scalar", &index->where);
+ gfc_error ("Array index at %L must be of INTEGER type",
+ &index->where);
return FAILURE;
}
- if (index->ts.kind != gfc_index_integer_kind)
+ if (index->ts.type == BT_REAL)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
+ &index->where) == FAILURE)
+ return FAILURE;
+
+ if (index->ts.kind != gfc_index_integer_kind
+ || index->ts.type != BT_INTEGER)
{
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
+ if (e->symtree == NULL)
+ return FAILURE;
+
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
{
break;
case EXEC_GOTO:
- if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
+ if (code->expr != NULL)
+ {
+ if (code->expr->ts.type != BT_INTEGER)
+ gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
- else
+ else if (code->expr->symtree->n.sym->attr.assign != 1)
+ gfc_error ("Variable '%s' has not been assigned a target label "
+ "at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
+ }
+ else
resolve_branch (code->label, code);
break;
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
+ sym->attr.dimension = sym->result->attr.dimension;
+ sym->attr.pointer = sym->result->attr.pointer;
}
}
}
if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
continue;
- if (cl->length->ts.type != BT_INTEGER)
- gfc_error
- ("Character length specification at %L must be of type INTEGER",
- &cl->length->where);
+ if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ continue;
+
+ if (gfc_specification_expr (cl->length) == FAILURE)
+ continue;
}
gfc_traverse_ns (ns, resolve_values);
OSDN Git Service
