/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *protected = "PROTECTED",
- *is_bind_c = "BIND(C)";
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
+ conf (entry, intrinsic);
- if (attr->if_source || attr->contained)
+ if ((attr->if_source && !attr->procedure) || attr->contained)
{
conf (external, subroutine);
conf (external, function);
conf (is_bind_c, cray_pointer);
conf (is_bind_c, cray_pointee);
conf (is_bind_c, allocatable);
+ conf (is_bind_c, elemental);
/* Need to also get volatile attr, according to 5.1 of F2003 draft.
Parameter conflict caught below. Also, value cannot be specified
goto conflict;
}
+ conf (procedure, allocatable)
+ conf (procedure, dimension)
+ conf (procedure, intrinsic)
+ conf (procedure, protected)
+ conf (procedure, target)
+ conf (procedure, value)
+ conf (procedure, volatile_)
+ conf (procedure, entry)
+ /* TODO: Implement procedure pointers. */
+ if (attr->procedure && attr->pointer)
+ {
+ gfc_error ("Fortran 2003: Procedure pointers at %L are "
+ "not yet implemented in gfortran", where);
+ return FAILURE;
+ }
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
- /* TODO: hmm, double check this. */
conf2 (value);
+ conf2 (is_bind_c);
break;
default:
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->elemental)
+ {
+ duplicate_attr ("ELEMENTAL", where);
+ return FAILURE;
+ }
+
attr->elemental = 1;
return check_conflict (attr, NULL, where);
}
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->pure)
+ {
+ duplicate_attr ("PURE", where);
+ return FAILURE;
+ }
+
attr->pure = 1;
return check_conflict (attr, NULL, where);
}
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->recursive)
+ {
+ duplicate_attr ("RECURSIVE", where);
+ return FAILURE;
+ }
+
attr->recursive = 1;
return check_conflict (attr, NULL, where);
}
}
+try
+gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return FAILURE;
+
+ if (attr->flavor != FL_PROCEDURE
+ && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
+ return FAILURE;
+
+ if (attr->procedure)
+ {
+ duplicate_attr ("PROCEDURE", where);
+ return FAILURE;
+ }
+
+ attr->procedure = 1;
+
+ return check_conflict (attr, NULL, where);
+}
+
+
/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
gfc_symtree *st;
int i;
- if (sym->components != NULL)
+ if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
if (sym->ns->parent == NULL)
/* Delete a symbol from the tree. Does not free the symbol itself! */
-static void
-delete_symtree (gfc_symtree **root, const char *name)
+void
+gfc_delete_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree st, *st0;
p = st->n.sym;
- if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
+ if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
+ && !(ns->proc_name
+ && ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && (ns->has_import_set || p->attr.imported)))
{
/* Symbol is from another namespace. */
gfc_error ("Symbol '%s' at %C has already been host associated",
if (p->new)
{
/* Symbol was new. */
- delete_symtree (&p->ns->sym_root, p->name);
+ if (p->attr.in_common && p->common_block->head)
+ {
+ /* If the symbol was added to any common block, it
+ needs to be removed to stop the resolver looking
+ for a (possibly) dead symbol. */
+
+ if (p->common_block->head == p)
+ p->common_block->head = p->common_next;
+ else
+ {
+ gfc_symbol *cparent, *csym;
+
+ cparent = p->common_block->head;
+ csym = cparent->common_next;
+
+ while (csym != p)
+ {
+ cparent = csym;
+ csym = csym->common_next;
+ }
+
+ gcc_assert(cparent->common_next == p);
+
+ cparent->common_next = csym->common_next;
+ }
+ }
+
+ gfc_delete_symtree (&p->ns->sym_root, p->name);
p->refs--;
if (p->refs < 0)
void
gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
{
- if (st != NULL)
- {
- (*func) (st);
+ if (!st)
+ return;
- gfc_traverse_symtree (st->left, func);
- gfc_traverse_symtree (st->right, func);
- }
+ gfc_traverse_symtree (st->left, func);
+ (*func) (st);
+ gfc_traverse_symtree (st->right, func);
}
if (st == NULL)
return;
+ traverse_ns (st->left, func);
+
if (st->n.sym->mark == 0)
(*func) (st->n.sym);
st->n.sym->mark = 1;
- traverse_ns (st->left, func);
traverse_ns (st->right, func);
}
}
+/* Return TRUE when name is the name of an intrinsic type. */
+
+bool
+gfc_is_intrinsic_typename (const char *name)
+{
+ if (strcmp (name, "integer") == 0
+ || strcmp (name, "real") == 0
+ || strcmp (name, "character") == 0
+ || strcmp (name, "logical") == 0
+ || strcmp (name, "complex") == 0
+ || strcmp (name, "doubleprecision") == 0
+ || strcmp (name, "doublecomplex") == 0)
+ return true;
+ else
+ return false;
+}
+
+
/* Return TRUE if the symbol is an automatic variable. */
static bool
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ /* Create a constructor with no expr, that way we can recognize if the user
+ tries to call the structure constructor for one of the iso_c_binding
+ derived types during resolution (resolve_structure_cons). */
tmp_sym->value->value.constructor = gfc_get_constructor ();
- /* This line will initialize the c_null_ptr/c_null_funptr
- c_address field to NULL. */
- tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
sym->attr.if_source = source;
}
+/* Copy the formal args from an existing symbol, src, into a new
+ symbol, dest. New formal args are created, and the description of
+ each arg is set according to the existing ones. This function is
+ used when creating procedure declaration variables from a procedure
+ declaration statement (see match_proc_decl()) to create the formal
+ args based on the args of a given named interface. */
+
+void copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
tmp_sym->value->value.character.string[0]
= (char) c_interop_kinds_table[s].value;
tmp_sym->value->value.character.string[1] = '\0';
+ tmp_sym->ts.cl = gfc_get_charlen ();
+ tmp_sym->ts.cl->length = gfc_int_expr (1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
new_symtree->n.sym->attr = old_sym->attr;
new_symtree->n.sym->ts = old_sym->ts;
new_symtree->n.sym->module = gfc_get_string (old_sym->module);
+ new_symtree->n.sym->from_intmod = old_sym->from_intmod;
+ new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
/* Build the formal arg list. */
build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
OSDN Git Service
