/* 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
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
minit ("USAGE", IFSRC_USAGE)
};
+const mstring save_status[] =
+{
+ minit ("UNKNOWN", SAVE_NONE),
+ minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
+ minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
+};
/* This is to make sure the backend generates setup code in the correct
order. */
*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;
}
}
+ if (attr->save == SAVE_EXPLICIT)
+ {
+ conf (dummy, save);
+ conf (in_common, save);
+ conf (result, save);
+
+ switch (attr->flavor)
+ {
+ case FL_PROGRAM:
+ case FL_BLOCK_DATA:
+ case FL_MODULE:
+ case FL_LABEL:
+ case FL_PROCEDURE:
+ case FL_DERIVED:
+ case FL_PARAMETER:
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+
+ case FL_VARIABLE:
+ case FL_NAMELIST:
+ default:
+ break;
+ }
+ }
+
conf (dummy, entry);
conf (dummy, intrinsic);
- conf (dummy, save);
conf (dummy, threadprivate);
conf (pointer, target);
conf (pointer, intrinsic);
conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
-
- if (attr->if_source || attr->contained)
+ conf (entry, intrinsic);
+
+ if ((attr->if_source && !attr->procedure) || attr->contained)
{
conf (external, subroutine);
conf (external, function);
conf (in_common, dummy);
conf (in_common, allocatable);
conf (in_common, result);
- conf (in_common, save);
- conf (result, save);
conf (dummy, result);
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
case FL_LABEL:
conf2 (dimension);
conf2 (dummy);
- conf2 (save);
conf2 (volatile_);
conf2 (pointer);
conf2 (protected);
case FL_PROCEDURE:
conf2 (intent);
- conf2 (save);
if (attr->subroutine)
{
case PROC_DUMMY:
conf2 (result);
conf2 (in_common);
- conf2 (save);
conf2 (threadprivate);
break;
case FL_DERIVED:
conf2 (dummy);
- conf2 (save);
conf2 (pointer);
conf2 (target);
conf2 (external);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
- conf2 (save);
conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
- /* TODO: hmm, double check this. */
conf2 (value);
+ conf2 (is_bind_c);
break;
default:
return FAILURE;
}
- if (attr->save)
+ if (attr->save == SAVE_EXPLICIT)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
return FAILURE;
}
- attr->save = 1;
+ attr->save = SAVE_EXPLICIT;
return check_conflict (attr, name, where);
}
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)
}
+/*******A helper function for creating new expressions*************/
+
+
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ lval = gfc_get_expr ();
+ lval->expr_type = EXPR_VARIABLE;
+ lval->where = sym->declared_at;
+ lval->ts = sym->ts;
+ lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
+ {
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
+ }
+
+ return lval;
+}
+
+
/************** Symbol table management subroutines ****************/
/* Basic details: Fortran 95 requires a potentially unlimited number
/* 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;
}
+/* Return a symtree node with a name that is guaranteed to be unique
+ within the namespace and corresponds to an illegal fortran name. */
+
+gfc_symtree *
+gfc_get_unique_symtree (gfc_namespace *ns)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int serial = 0;
+
+ sprintf (name, "@%d", serial++);
+ return gfc_new_symtree (&ns->sym_root, name);
+}
+
+
/* Given a name find a user operator node, creating it if it doesn't
exist. These are much simpler than symbols because they can't be
ambiguous with one another. */
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
/* Set up the symbol's important fields. Save attr required so we can
initialize the ptr to NULL. */
- tmp_sym->attr.save = 1;
+ tmp_sym->attr.save = SAVE_EXPLICIT;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->attr.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
current ns. */
generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
- (char *) (ptr_id == ISOCBINDING_NULL_PTR
+ (const char *) (ptr_id == ISOCBINDING_NULL_PTR
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
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;
gen_cptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *c_ptr_name)
+ gfc_namespace *ns, const char *c_ptr_name,
+ int iso_c_sym_id)
{
gfc_symbol *param_sym = NULL;
gfc_symbol *c_ptr_sym = NULL;
gfc_symtree *param_symtree = NULL;
gfc_formal_arglist *formal_arg = NULL;
const char *c_ptr_in;
- const char *c_ptr_type = "c_ptr";
+ const char *c_ptr_type = NULL;
+
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
+ else
+ c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
if(c_ptr_name == NULL)
c_ptr_in = "gfc_cptr__";
param_sym->attr.value = 1;
param_sym->attr.use_assoc = 1;
- /* Get the symbol for c_ptr, no matter what it's name is (user renamed). */
- c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
+ (user renamed). */
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ else
+ c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
if (c_ptr_sym == NULL)
{
/* This can happen if the user did not define c_ptr but they are
trying to use one of the iso_c_binding functions that need it. */
- gfc_error_now ("Type 'C_PTR' required for ISO_C_BINDING function at %C");
- generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
- (char *) "_gfortran_iso_c_binding_c_ptr");
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
+ (const char *)c_ptr_type);
+ else
+ generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
+ (const char *)c_ptr_type);
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
- /* Integer array, rank 1, describing the shape of the object. */
- param_sym->ts.type = BT_INTEGER;
+ /* Integer array, rank 1, describing the shape of the object. Make it's
+ type BT_VOID initially so we can accept any type/kind combination of
+ integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
+ of BT_INTEGER type. */
+ param_sym->ts.type = BT_VOID;
+
+ /* Initialize the kind to default integer. However, it will be overridden
+ during resolution to match the kind of the SHAPE parameter given as
+ the actual argument (to allow for any valid integer kind). */
param_sym->ts.kind = gfc_default_integer_kind;
param_sym->as = gfc_get_array_spec ();
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
(old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr");
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "fptr");
/* c_associated has one required arg and one optional; both
are c_ptrs. */
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_1");
+ gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
if (add_optional_arg)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_2");
+ gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
/* The last param is optional so mark it as such. */
tail->sym->attr.optional = 1;
}
void
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
- char *local_name)
+ const char *local_name)
{
- char *name = (local_name && local_name[0]) ? local_name
+ const char *const name = (local_name && local_name[0]) ? local_name
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
gfc_symbol *tmp_sym = NULL;
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. */
/* Create the necessary derived type so we can continue
processing the file. */
generate_isocbinding_symbol
- (mod_name, s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR : ISOCBINDING_FUNPTR,
- (char *)(s == ISOCBINDING_FUNLOC
+ (mod_name, s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
+ (const char *)(s == ISOCBINDING_FUNLOC
? "_gfortran_iso_c_binding_c_funptr"
: "_gfortran_iso_c_binding_c_ptr"));
tmp_sym->ts.derived =
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
