/* 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"
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");
*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:
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);
}
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);
}
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);
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);
}
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);
}
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. */
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;
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;
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)
lp = lp->right;
}
- lp = gfc_getmem (sizeof (gfc_st_label));
+ lp = XCNEW (gfc_st_label);
lp->value = labelno;
lp->defined = ST_LABEL_UNKNOWN;
}
+/*******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;
}
if (sym->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 = 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)
}
+/* 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)
{
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);
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
- ? 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);
projects / gcc.git / blobdiff