/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
- gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc))
{
|| sym->attr.flavor == FL_VARIABLE))
return;
- /* Try to find out of what type the function is. If there was an
- explicit RESULT clause, try to get the type from it. If the
- function is never defined, set it to the implicit type. If
- even that fails, give up. */
+ /* Try to find out of what the return type is. */
if (sym->result != NULL)
sym = sym->result;
if (sym->ts.type == BT_UNKNOWN)
{
- /* Assume we can find an implicit type. */
- t = SUCCESS;
-
- if (sym->result == NULL)
- t = gfc_set_default_type (sym, 0, ns);
- else
- {
- if (sym->result->ts.type == BT_UNKNOWN)
- t = gfc_set_default_type (sym->result, 0, NULL);
-
- sym->ts = sym->result->ts;
- }
+ t = gfc_set_default_type (sym, 0, ns);
if (t == FAILURE)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
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_procedure (&proc->attr, PROC_INTERNAL, NULL);
+ gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
if (ns->proc_name->attr.subroutine)
- gfc_add_subroutine (&proc->attr, NULL);
+ gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
- gfc_add_function (&proc->attr, NULL);
- gfc_internal_error ("TODO: Functions with alternate entry points");
+ gfc_symbol *sym;
+ gfc_typespec *ts, *fts;
+
+ gfc_add_function (&proc->attr, proc->name, NULL);
+ 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. */
/* Resolve all subnodes-- give them types. */
- switch (e->operator)
+ switch (e->value.op.operator)
{
default:
- if (gfc_resolve_expr (e->op2) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
return FAILURE;
/* Fall through... */
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- if (gfc_resolve_expr (e->op1) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
}
/* Typecheck the new node. */
- op1 = e->op1;
- op2 = e->op2;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
}
sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
- gfc_op2string (e->operator), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
sprintf (msg,
"Operands of binary numeric operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
}
sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
}
sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
if (op2 == NULL)
sprintf (msg, "Operand of user operator '%s' at %%L is %s",
- e->uop->name, gfc_typename (&op1->ts));
+ e->value.op.uop->name, gfc_typename (&op1->ts));
else
sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
- e->uop->name, gfc_typename (&op1->ts),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
t = SUCCESS;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
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)
{
/* Count this merge. */
nmerges++;
- /* Cut the list in two pieces by steppin INSIZE places
+ /* Cut the list in two pieces by stepping INSIZE places
forward in the list, starting from P. */
psize = 0;
q = p;
}
-/* Check to see if an expression is suitable for use in a CASE
- statement. Makes sure that all case expressions are scalar
- constants of the same type/kind. Return FAILURE if anything
- is wrong. */
+/* Check to see if an expression is suitable for use in a CASE statement.
+ Makes sure that all case expressions are scalar constants of the same
+ type. Return FAILURE if anything is wrong. */
static try
validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
{
- gfc_typespec case_ts = case_expr->ts;
-
if (e == NULL) return SUCCESS;
- if (e->ts.type != case_ts.type)
+ if (e->ts.type != case_expr->ts.type)
{
gfc_error ("Expression in CASE statement at %L must be of type %s",
- &e->where, gfc_basic_typename (case_ts.type));
+ &e->where, gfc_basic_typename (case_expr->ts.type));
return FAILURE;
}
- if (e->ts.kind != case_ts.kind)
+ /* C805 (R808) For a given case-construct, each case-value shall be of
+ the same type as case-expr. For character type, length differences
+ are allowed, but the kind type parameters shall be the same. */
+
+ if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
- &e->where, case_ts.kind);
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
+ /* Convert the case value kind to that of case expression kind, if needed.
+ FIXME: Should a warning be issued? */
+ if (e->ts.kind != case_expr->ts.kind)
+ gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
+
if (e->rank != 0)
{
gfc_error ("Expression in CASE statement at %L must be scalar",
return;
}
+ /* PR 19168 has a long discussion concerning a mismatch of the kinds
+ of the SELECT CASE expression and its CASE values. Walk the lists
+ of case values, and if we find a mismatch, promote case_expr to
+ the appropriate kind. */
+
+ if (type == BT_LOGICAL || type == BT_INTEGER)
+ {
+ for (body = code->block; body; body = body->block)
+ {
+ /* Walk the case label list. */
+ for (cp = body->ext.case_list; cp; cp = cp->next)
+ {
+ /* Intercept the DEFAULT case. It does not have a kind. */
+ if (cp->low == NULL && cp->high == NULL)
+ continue;
+
+ /* Unreachable case ranges are discarded, so ignore. */
+ if (cp->low != NULL && cp->high != NULL
+ && cp->low != cp->high
+ && gfc_compare_expr (cp->low, cp->high) > 0)
+ continue;
+
+ /* FIXME: Should a warning be issued? */
+ if (cp->low != NULL
+ && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
+ gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
+
+ if (cp->high != NULL
+ && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
+ gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
+ }
+ }
+ }
+
/* Assume there is no DEFAULT case. */
default_case = NULL;
head = tail = NULL;
gfc_error ("Unsupported statement while finding forall index in "
"expression");
break;
- default:
+
+ case EXPR_OP:
+ /* Find the FORALL index in the first operand. */
+ if (expr->value.op.op1)
+ {
+ if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
+ return SUCCESS;
+ }
+
+ /* Find the FORALL index in the second operand. */
+ if (expr->value.op.op2)
+ {
+ if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
- }
- /* Find the FORALL index in the first operand. */
- if (expr->op1)
- {
- if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
- return SUCCESS;
+ default:
+ break;
}
- /* Find the FORALL index in the second operand. */
- if (expr->op2)
- {
- if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
- return SUCCESS;
- }
return FAILURE;
}
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;
int formal_ns_save, check_constant, mp_flag;
int i;
const char *whynot;
-
+ gfc_namelist *nl;
if (sym->attr.flavor == FL_UNKNOWN)
{
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 (sym->attr.flavor == FL_VARIABLE)
+ switch (sym->attr.flavor)
{
+ case FL_VARIABLE:
/* Can the sybol have an initializer? */
whynot = NULL;
if (sym->attr.allocatable)
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
sym->value = gfc_default_initializer (&sym->ts);
+ break;
+
+ case FL_NAMELIST:
+ /* Reject PRIVATE objects in a PUBLIC namelist. */
+ if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ if (!gfc_check_access(nl->sym->attr.access,
+ nl->sym->ns->default_access))
+ gfc_error ("PRIVATE symbol '%s' cannot be member of "
+ "PUBLIC namelist at %L", nl->sym->name,
+ &sym->declared_at);
+ }
+ }
+ break;
+
+ default:
+ break;
}
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
