}
+static void
+resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
+{
+ try t;
+
+ /* If this namespace is not a function, ignore it. */
+ if (! sym
+ || !(sym->attr.function
+ || 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. */
+ 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;
+ }
+
+ if (t == FAILURE)
+ gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at); /* FIXME */
+ }
+}
+
+
+/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
+ introduce duplicates. */
+
+static void
+merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+ gfc_formal_arglist *f, *new_arglist;
+ gfc_symbol *new_sym;
+
+ for (; new_args != NULL; new_args = new_args->next)
+ {
+ new_sym = new_args->sym;
+ /* See if ths arg is already in the formal argument list. */
+ for (f = proc->formal; f; f = f->next)
+ {
+ if (new_sym == f->sym)
+ break;
+ }
+
+ if (f)
+ continue;
+
+ /* Add a new argument. Argument order is not important. */
+ new_arglist = gfc_get_formal_arglist ();
+ new_arglist->sym = new_sym;
+ new_arglist->next = proc->formal;
+ proc->formal = new_arglist;
+ }
+}
+
+
+/* Resolve alternate entry points. If a symbol has multiple entry points we
+ create a new master symbol for the main routine, and turn the existing
+ symbol into an entry point. */
+
+static void
+resolve_entries (gfc_namespace * ns)
+{
+ gfc_namespace *old_ns;
+ gfc_code *c;
+ gfc_symbol *proc;
+ gfc_entry_list *el;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int master_count = 0;
+
+ if (ns->proc_name == NULL)
+ return;
+
+ /* No need to do anything if this procedure doesn't have alternate entry
+ points. */
+ if (!ns->entries)
+ return;
+
+ /* We may already have resolved alternate entry points. */
+ if (ns->proc_name->attr.entry_master)
+ return;
+
+ /* If this isn't a procedure something has gone horribly wrong. */
+ assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
+
+ /* Remember the current namespace. */
+ old_ns = gfc_current_ns;
+
+ gfc_current_ns = ns;
+
+ /* Add the main entry point to the list of entry points. */
+ el = gfc_get_entry_list ();
+ el->sym = ns->proc_name;
+ el->id = 0;
+ el->next = ns->entries;
+ ns->entries = el;
+ ns->proc_name->attr.entry = 1;
+
+ /* Add an entry statement for it. */
+ c = gfc_get_code ();
+ c->op = EXEC_ENTRY;
+ c->ext.entry = el;
+ c->next = ns->code;
+ ns->code = c;
+
+ /* Create a new symbol for the master function. */
+ /* Give the internal function a unique name (within this file).
+ Also include the function name so the user has some hope of figuring
+ 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);
+ assert (proc != NULL);
+
+ gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
+ if (ns->proc_name->attr.subroutine)
+ gfc_add_subroutine (&proc->attr, NULL);
+ else
+ {
+ gfc_add_function (&proc->attr, NULL);
+ gfc_internal_error ("TODO: Functions with alternate entry points");
+ }
+ proc->attr.access = ACCESS_PRIVATE;
+ proc->attr.entry_master = 1;
+
+ /* Merge all the entry point arguments. */
+ for (el = ns->entries; el; el = el->next)
+ merge_argument_lists (proc, el->sym->formal);
+
+ /* Use the master function for the function body. */
+ ns->proc_name = proc;
+
+ /* Finalize the new symbols. */
+ gfc_commit_symbols ();
+
+ /* Restore the original namespace. */
+ gfc_current_ns = old_ns;
+}
+
+
/* Resolve contained function types. Because contained functions can call one
another, they have to be worked out before any of the contained procedures
can be resolved.
static void
resolve_contained_functions (gfc_namespace * ns)
{
- gfc_symbol *contained_sym, *sym_lower;
gfc_namespace *child;
- try t;
+ gfc_entry_list *el;
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
{
- sym_lower = child->proc_name;
-
- /* If this namespace is not a function, ignore it. */
- if (! sym_lower
- || !( sym_lower->attr.function
- || sym_lower->attr.flavor == FL_VARIABLE))
- continue;
-
- /* Find the contained symbol in the current namespace. */
- gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym);
-
- if (contained_sym == NULL)
- gfc_internal_error ("resolve_contained_functions(): Contained "
- "function not found in parent namespace");
-
- /* 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. */
- if (sym_lower->result != NULL)
- sym_lower = sym_lower->result;
-
- if (sym_lower->ts.type == BT_UNKNOWN)
- {
- /* Assume we can find an implicit type. */
- t = SUCCESS;
-
- if (sym_lower->result == NULL)
- t = gfc_set_default_type (sym_lower, 0, child);
- else
- {
- if (sym_lower->result->ts.type == BT_UNKNOWN)
- t = gfc_set_default_type (sym_lower->result, 0, NULL);
-
- sym_lower->ts = sym_lower->result->ts;
- }
-
- if (t == FAILURE)
- gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
- sym_lower->name, &sym_lower->declared_at); /* FIXME */
- }
+ /* Resolve alternate entry points first. */
+ resolve_entries (child);
- /* If the symbol in the parent of the contained namespace is not
- the same as the one in contained namespace itself, copy over
- the type information. */
- /* ??? Shouldn't we replace the symbol with the parent symbol instead? */
- if (contained_sym != sym_lower)
- {
- contained_sym->ts = sym_lower->ts;
- contained_sym->as = gfc_copy_array_spec (sym_lower->as);
- }
+ /* Then check function return types. */
+ resolve_contained_fntype (child->proc_name, child);
+ for (el = child->entries; el; el = el->next)
+ resolve_contained_fntype (el->sym, child);
}
}
/****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or
- or attribute declaration statement, nonzero otherwise. */
+ attribute declaration statement, nonzero otherwise. */
static int
was_declared (gfc_symbol * sym)
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_LOGICAL;
- e->ts.kind = gfc_default_logical_kind ();
+ e->ts.kind = gfc_default_logical_kind;
break;
}
gfc_type_convert_binary (e);
e->ts.type = BT_LOGICAL;
- e->ts.kind = gfc_default_logical_kind ();
+ e->ts.kind = gfc_default_logical_kind;
break;
}
if (e == NULL) return SUCCESS;
- if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Expression in CASE statement at %L must be a constant",
- &e->where);
- return FAILURE;
- }
-
if (e->ts.type != case_ts.type)
{
gfc_error ("Expression in CASE statement at %L must be of type %s",
{
case EXEC_NOP:
case EXEC_CYCLE:
- case EXEC_IOLENGTH:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_TRANSFER:
+ case EXEC_ENTRY:
break;
case EXEC_WHERE:
case EXEC_INQUIRE:
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
+ break;
+
+ resolve_branch (code->ext.inquire->err, code);
+ break;
+
+ case EXEC_IOLENGTH:
+ assert(code->ext.inquire != NULL);
+ if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
break;
resolve_branch (code->ext.inquire->err, code);
if (sym->ts.type == BT_UNKNOWN)
{
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
- gfc_set_default_type (sym, 0, NULL);
+ gfc_set_default_type (sym, 1, NULL);
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
{
}
}
+ /* Assumed size arrays and assumed shape arrays must be dummy
+ arguments. */
+
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
return;
}
- if (sym->attr.flavor == FL_PARAMETER
- && sym->as != NULL && sym->as->type != AS_EXPLICIT)
+ /* A parameter array's shape needs to be constant. */
+
+ if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
+ && !gfc_is_compile_time_shape (sym->as))
{
- gfc_error ("Parameter array '%s' at %L must have an explicit shape",
- sym->name, &sym->declared_at);
- return;
+ gfc_error ("Parameter array '%s' at %L cannot be automatic "
+ "or assumed shape", sym->name, &sym->declared_at);
+ return;
}
/* Make sure that character string variables with assumed length are
static struct
{
gfc_data_value *vnode;
- int left;
+ unsigned int left;
}
values;
static try
next_data_value (void)
{
-
while (values.left == 0)
{
if (values.vnode->next == NULL)
values.left = values.vnode->repeat;
}
- values.left--;
return SUCCESS;
}
mpz_t size;
mpz_t offset;
try t;
- int mark = 0;
+ ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
gfc_ref *ref;
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->rank == 0)
- mpz_init_set_ui (size, 1);
+ {
+ mpz_init_set_ui (size, 1);
+ ref = NULL;
+ }
else
{
ref = e->ref;
switch (ref->u.ar.type)
{
case AR_FULL:
- mark = 1;
+ mark = AR_FULL;
break;
case AR_SECTION:
ar = &ref->u.ar;
/* Get the start position of array section. */
gfc_get_section_index (ar, section_index, &offset);
- mark = 2;
+ mark = AR_SECTION;
break;
default:
if (t == FAILURE)
break;
+ /* If we have more than one element left in the repeat count,
+ and we have more than one element left in the target variable,
+ then create a range assignment. */
+ /* ??? Only done for full arrays for now, since array sections
+ seem tricky. */
+ if (mark == AR_FULL && ref && ref->next == NULL
+ && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
+ {
+ mpz_t range;
+
+ if (mpz_cmp_ui (size, values.left) >= 0)
+ {
+ mpz_init_set_ui (range, values.left);
+ mpz_sub_ui (size, size, values.left);
+ values.left = 0;
+ }
+ else
+ {
+ mpz_init_set (range, size);
+ values.left -= mpz_get_ui (size);
+ mpz_set_ui (size, 0);
+ }
+
+ gfc_assign_data_value_range (var->expr, values.vnode->expr,
+ offset, range);
+
+ mpz_add (offset, offset, range);
+ mpz_clear (range);
+ }
+
/* Assign initial value to symbol. */
- gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ else
+ {
+ values.left -= 1;
+ mpz_sub_ui (size, size, 1);
- if (mark == 1)
- mpz_add_ui (offset, offset, 1);
+ gfc_assign_data_value (var->expr, values.vnode->expr, offset);
- /* Modify the array section indexes and recalculate the offset for
- next element. */
- else if (mark == 2)
- gfc_advance_section (section_index, ar, &offset);
+ if (mark == AR_FULL)
+ mpz_add_ui (offset, offset, 1);
- mpz_sub_ui (size, size, 1);
+ /* Modify the array section indexes and recalculate the offset
+ for next element. */
+ else if (mark == AR_SECTION)
+ gfc_advance_section (section_index, ar, &offset);
+ }
}
- if (mark == 2)
+
+ if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
mpz_clear (section_index[i]);
static try
resolve_data_variables (gfc_data_variable * d)
{
-
for (; d; d = d->next)
{
if (d->list == NULL)
static void
resolve_data (gfc_data * d)
{
-
if (resolve_data_variables (d->var) == FAILURE)
return;
int
gfc_impure_variable (gfc_symbol * sym)
{
-
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
old_ns = gfc_current_ns;
gfc_current_ns = ns;
+ resolve_entries (ns);
+
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_symbol);
gfc_current_ns = old_ns;
}
-
OSDN Git Service
