/* 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"
/* Prepare for a new implicit range. Sets flags in new_flag[]. */
-try
+gfc_try
gfc_add_new_implicit_range (int c1, int c2)
{
int i;
/* Add a matched implicit range for gfc_set_implicit(). Check if merging
the new implicit types back into the existing types will work. */
-try
+gfc_try
gfc_merge_new_implicit (gfc_typespec *ts)
{
int i;
letter = sym->name[0];
if (gfc_option.flag_allow_leading_underscore && letter == '_')
- gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
+ gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
"gfortran developers, and should not be used for "
"implicitly typed variables");
letter of its name. Fails if the letter in question has no default
type. */
-try
+gfc_try
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
gfc_typespec *ts;
{
/* Dummy args to a BIND(C) routine may not be interoperable if
they are implicitly typed. */
- gfc_warning_now ("Implicity declared variable '%s' at %L may not "
+ gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
"be C interoperable but it is a dummy argument to "
"the BIND(C) procedure '%s' at %L", sym->name,
&(sym->declared_at), sym->ns->proc_name->name,
goto conflict_std;\
}
-static try
+static gfc_try
check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
*intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
*allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
- *private = "PRIVATE", *recursive = "RECURSIVE",
+ *privat = "PRIVATE", *recursive = "RECURSIVE",
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
- *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
+ *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*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)";
+ *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
if (attr->optional)
a1 = optional;
if (attr->access == ACCESS_PRIVATE)
- a1 = private;
+ a1 = privat;
if (attr->access == ACCESS_PUBLIC)
- a1 = public;
+ a1 = publik;
if (attr->intent != INTENT_UNKNOWN)
a1 = intent;
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_PROCEDURE:
+ if (attr->proc_pointer)
+ break;
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+
case FL_VARIABLE:
case FL_NAMELIST:
default:
conf (target, external);
conf (target, intrinsic);
- conf (external, dimension); /* See Fortran 95's R504. */
+
+ if (!attr->if_source)
+ conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
+ conf (entry, intrinsic);
- if (attr->if_source || attr->contained)
+ if ((attr->if_source == IFSRC_DECL && !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 (protected, intrinsic)
- conf (protected, external)
- conf (protected, in_common)
+ conf (is_protected, intrinsic)
+ conf (is_protected, external)
+ conf (is_protected, in_common)
conf (volatile_, intrinsic)
conf (volatile_, external)
goto conflict;
}
+ conf (procedure, allocatable)
+ conf (procedure, dimension)
+ conf (procedure, intrinsic)
+ conf (procedure, is_protected)
+ conf (procedure, target)
+ conf (procedure, value)
+ conf (procedure, volatile_)
+ conf (procedure, entry)
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
conf2 (dummy);
conf2 (volatile_);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+
+ if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
+ {
+ a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
+ gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
+ name, where);
+ return FAILURE;
+ }
+
+ if (attr->is_bind_c)
+ {
+ gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
+ return FAILURE;
+ }
+
break;
case FL_VARIABLE:
break;
case FL_PROCEDURE:
- conf2 (intent);
+ if (!attr->proc_pointer)
+ conf2 (intent);
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
- /* TODO: hmm, double check this. */
conf2 (value);
+ conf2 (is_bind_c);
break;
default:
/* Called from decl.c (attr_decl1) to check attributes, when declared
separately. */
-try
+gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
return FAILURE;
}
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
+ where);
+ return FAILURE;
+ }
+
attr->allocatable = 1;
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
return FAILURE;
}
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
+ "at %L", name, where);
+ return FAILURE;
+ }
+
attr->dimension = 1;
return check_conflict (attr, name, where);
}
-try
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
return FAILURE;
}
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_optional (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return FAILURE;
- if (attr->protected)
+ if (attr->is_protected)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate PROTECTED attribute specified at %L",
return FAILURE;
}
- attr->protected = 1;
+ attr->is_protected = 1;
return check_conflict (attr, name, where);
}
-try
+gfc_try
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
}
-try
+gfc_try
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_target (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_elemental (symbol_attribute *attr, locus *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);
}
-try
+gfc_try
gfc_add_pure (symbol_attribute *attr, locus *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);
}
-try
+gfc_try
gfc_add_recursive (symbol_attribute *attr, locus *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_try
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
}
+gfc_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. */
-try
+gfc_try
gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
locus *where)
{
}
-try
+gfc_try
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
/* No checks for use-association in public and private statements. */
-try
+gfc_try
gfc_add_access (symbol_attribute *attr, gfc_access access,
const char *name, locus *where)
{
/* Set the is_bind_c field for the given symbol_attribute. */
-try
+gfc_try
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
int is_proc_lang_bind_spec)
{
}
-try
+gfc_try
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
gfc_formal_arglist * formal, locus *where)
{
return FAILURE;
}
+ if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
+ {
+ gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
+ "body", sym->name, where);
+ return FAILURE;
+ }
+
sym->formal = formal;
sym->attr.if_source = source;
/* Add a type to a symbol. */
-try
+gfc_try
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
/* Check for missing attributes in the new symbol. Currently does
nothing, but it's not clear that it is unnecessary yet. */
-try
+gfc_try
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
locus *where ATTRIBUTE_UNUSED)
{
attributes have a lot of side-effects but cannot be present given
where we are called from, so we ignore some bits. */
-try
+gfc_try
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
int is_proc_lang_bind_spec;
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
- if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+ if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
return SUCCESS;
already present. On success, the component pointer is modified to
point to the additional component structure. */
-try
+gfc_try
gfc_add_component (gfc_symbol *sym, const char *name,
gfc_component **component)
{
tail = p;
}
+ if (sym->attr.extension
+ && gfc_find_component (sym->components->ts.derived, name))
+ {
+ gfc_error ("Component '%s' at %C already in the parent type "
+ "at %L", name, &sym->components->ts.derived->declared_at);
+ return FAILURE;
+ }
+
/* Allocate a new component. */
p = gfc_get_component ();
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)
if (strcmp (p->name, name) == 0)
break;
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ p = gfc_find_component (sym->components->ts.derived, name);
+ /* Do not overwrite the error. */
+ if (p == NULL)
+ return p;
+ }
+
if (p == NULL)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else
+
+ else if (sym->attr.use_assoc)
{
- if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
- || p->access == ACCESS_PRIVATE))
+ if (p->access == ACCESS_PRIVATE)
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
- p = NULL;
+ return NULL;
+ }
+
+ /* If there were components given and all components are private, error
+ out at this place. */
+ if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
+ {
+ gfc_error ("All components of '%s' are PRIVATE in structure"
+ " constructor at %C", sym->name);
+ return NULL;
}
}
lp = lp->right;
}
- lp = gfc_getmem (sizeof (gfc_st_label));
+ lp = XCNEW (gfc_st_label);
lp->value = labelno;
lp->defined = ST_LABEL_UNKNOWN;
updating the unknown state. Returns FAILURE if something goes
wrong. */
-try
+gfc_try
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
gfc_sl_type label_type;
int labelno;
- try rc;
+ gfc_try rc;
if (lp == NULL)
return SUCCESS;
}
+/*******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
gfc_intrinsic_op in;
int i;
- ns = gfc_getmem (sizeof (gfc_namespace));
+ ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
+ ns->finalizers = NULL;
ns->default_access = ACCESS_UNKNOWN;
ns->parent = parent;
{
gfc_symtree *st;
- st = gfc_getmem (sizeof (gfc_symtree));
+ st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
gfc_insert_bbt (root, st, compare_symtree);
/* 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. */
st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
- uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
+ uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
uop->ns = gfc_current_ns;
gfc_free_formal_arglist (sym->formal);
+ gfc_free_namespace (sym->f2k_derived);
+
gfc_free (sym);
}
{
gfc_symbol *p;
- p = gfc_getmem (sizeof (gfc_symbol));
+ p = XCNEW (gfc_symbol);
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
/* Clear the ptrs we may need. */
p->common_block = NULL;
+ p->f2k_derived = NULL;
return p;
}
save_symbol_data (gfc_symbol *sym)
{
- if (sym->new || sym->old_symbol != NULL)
+ if (sym->gfc_new || sym->old_symbol != NULL)
return;
- sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
+ sym->old_symbol = XCNEW (gfc_symbol);
*(sym->old_symbol) = *sym;
sym->tlink = changed_syms;
p->old_symbol = NULL;
p->tlink = changed_syms;
p->mark = 1;
- p->new = 1;
+ p->gfc_new = 1;
changed_syms = p;
st = gfc_new_symtree (&ns->sym_root, name);
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",
{
q = p->tlink;
- if (p->new)
+ if (p->gfc_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)
q = p->tlink;
p->tlink = NULL;
p->mark = 0;
- p->new = 0;
+ p->gfc_new = 0;
free_old_symbol (p);
}
changed_syms = NULL;
sym->tlink = NULL;
sym->mark = 0;
- sym->new = 0;
+ sym->gfc_new = 0;
free_old_symbol (sym);
}
free_uop_tree (uop_tree->left);
free_uop_tree (uop_tree->right);
- gfc_free_interface (uop_tree->n.uop->operator);
+ gfc_free_interface (uop_tree->n.uop->op);
gfc_free (uop_tree->n.uop);
gfc_free (uop_tree);
}
+/* Free a finalizer procedure list. */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+ if (el)
+ {
+ --el->procedure->refs;
+ if (!el->procedure->refs)
+ gfc_free_symbol (el->procedure);
+
+ gfc_free (el);
+ }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+ while (list)
+ {
+ gfc_finalizer* current = list;
+ list = list->next;
+ gfc_free_finalizer (current);
+ }
+}
+
+
/* Free a namespace structure and everything below it. Interface
lists associated with intrinsic operators are not freed. These are
taken care of when a specific name is freed. */
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ gfc_free_finalizer_list (ns->finalizers);
for (cl = ns->cl_list; cl; cl = cl2)
{
gfc_free_equiv_lists (ns->equiv_lists);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
- gfc_free_interface (ns->operator[i]);
+ gfc_free_interface (ns->op[i]);
gfc_free_data (ns->data);
p = ns->contained;
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
if (s != NULL)
return s;
- s = gfc_getmem (sizeof (gfc_gsymbol));
+ s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string (name);
for such. If an error occurs, the errors are reported here, allowing for
multiple errors to be handled for a single derived type. */
-try
+gfc_try
verify_bind_c_derived_type (gfc_symbol *derived_sym)
{
gfc_component *curr_comp = NULL;
- try is_c_interop = FAILURE;
- try retval = SUCCESS;
+ gfc_try is_c_interop = FAILURE;
+ gfc_try retval = SUCCESS;
if (derived_sym == NULL)
gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
-static try
+static gfc_try
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
const char *module_name)
{
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;
trying to use one of the iso_c_binding functions that need it. */
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
- (char *)c_ptr_type);
+ (const char *)c_ptr_type);
else
generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
- (char *)c_ptr_type);
+ (const char *)c_ptr_type);
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name)
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
- param_sym->attr.pointer = 1;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
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;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+
+ /* 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
gfc_current_ns->proc_name = new_proc_sym;
/* Generate the params. */
- if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr");
-
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_shape_param (&head, &tail,
- (const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
- }
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
gfc_current_ns = parent_ns;
}
+static int
+std_for_isocbinding_symbol (int id)
+{
+ switch (id)
+ {
+#define NAMED_INTCST(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+ default:
+ return GFC_STD_F2003;
+ }
+}
/* Generate the given set of C interoperable kind objects, or all
interoperable kinds. This function will only be given kind objects
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;
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
+ if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
+ return;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Already exists in this scope so don't re-add it.
switch (s)
{
-#define NAMED_INTCST(a,b,c) case a :
+#define NAMED_INTCST(a,b,c,d) case a :
#define NAMED_REALCST(a,b,c) case a :
#define NAMED_CMPXCST(a,b,c) case a :
#define NAMED_LOGCST(a,b,c) case a :
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
- tmp_sym->value->value.character.string = gfc_getmem (2);
+ tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
- = (char) c_interop_kinds_table[s].value;
+ = (gfc_char_t) 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
- || s == ISOCBINDING_F_PROCPOINTER
- ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
- (char *)(s == ISOCBINDING_FUNLOC
- || s == ISOCBINDING_F_PROCPOINTER
+ (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);