/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "gfortran.h"
#include "parse.h"
+
/* Strings for all symbol attributes. We use these for dumping the
parse tree, in error messages, and also when reading and writing
modules. */
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. */
the new implicit types back into the existing types will work. */
try
-gfc_merge_new_implicit (gfc_typespec * ts)
+gfc_merge_new_implicit (gfc_typespec *ts)
{
int i;
/* Given a symbol, return a pointer to the typespec for its default type. */
gfc_typespec *
-gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
+gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
{
char letter;
type. */
try
-gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
+gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
gfc_typespec *ts;
sym->ts = *ts;
sym->attr.implicit_type = 1;
+ if (sym->attr.is_bind_c == 1)
+ {
+ /* BIND(C) variables should not be implicitly declared. */
+ gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
+ "not be C interoperable", sym->name, &sym->declared_at);
+ sym->ts.f90_type = sym->ts.type;
+ }
+
+ if (sym->attr.dummy != 0)
+ {
+ if (sym->ns->proc_name != NULL
+ && (sym->ns->proc_name->attr.subroutine != 0
+ || sym->ns->proc_name->attr.function != 0)
+ && sym->ns->proc_name->attr.is_bind_c != 0)
+ {
+ /* 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 "
+ "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,
+ &(sym->ns->proc_name->declared_at));
+ sym->ts.f90_type = sym->ts.type;
+ }
+ }
+
return SUCCESS;
}
== SUCCESS)
{
if (proc->result != proc)
- proc->ts = proc->result->ts;
+ {
+ proc->ts = proc->result->ts;
+ proc->as = gfc_copy_array_spec (proc->result->as);
+ proc->attr.dimension = proc->result->attr.dimension;
+ proc->attr.pointer = proc->result->attr.pointer;
+ proc->attr.allocatable = proc->result->attr.allocatable;
+ }
}
else
{
- gfc_error ("unable to implicitly type the function result "
- "'%s' at %L", proc->result->name,
- &proc->result->declared_at);
+ gfc_error ("Function result '%s' at %L has no IMPLICIT type",
+ proc->result->name, &proc->result->declared_at);
proc->result->attr.untyped = 1;
}
}
}
static try
-check_conflict (symbol_attribute * attr, const char * name, locus * where)
+check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
*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";
+ *volatile_ = "VOLATILE", *protected = "PROTECTED",
+ *is_bind_c = "BIND(C)";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
if (a1 != NULL)
{
gfc_error
- ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
- where);
+ ("%s attribute not allowed in BLOCK DATA program unit at %L",
+ a1, where);
return FAILURE;
}
}
+ 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, external);
conf (pointer, intrinsic);
conf (pointer, elemental);
conf (allocatable, elemental);
conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
-
+
if (attr->if_source || attr->contained)
{
conf (external, subroutine);
conf (in_common, dummy);
conf (in_common, allocatable);
conf (in_common, result);
- conf (in_common, save);
- conf (result, save);
conf (dummy, result);
conf (function, subroutine);
+ if (!function && !subroutine)
+ conf (is_bind_c, dummy);
+
+ conf (is_bind_c, cray_pointer);
+ conf (is_bind_c, cray_pointee);
+ conf (is_bind_c, allocatable);
+
+ /* Need to also get volatile attr, according to 5.1 of F2003 draft.
+ Parameter conflict caught below. Also, value cannot be specified
+ for a dummy procedure. */
+
/* Cray pointer/pointee conflicts. */
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
conf (data, allocatable);
conf (data, use_assoc);
- conf (protected, intrinsic)
- conf (protected, external)
- conf (protected, in_common)
-
conf (value, pointer)
conf (value, allocatable)
conf (value, subroutine)
conf (value, dimension)
conf (value, external)
- if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+ if (attr->value
+ && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
{
a1 = value;
a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
goto conflict;
}
+ conf (protected, intrinsic)
+ conf (protected, external)
+ conf (protected, in_common)
+
conf (volatile_, intrinsic)
conf (volatile_, external)
if (attr->in_namelist
&& attr->flavor != FL_VARIABLE
+ && attr->flavor != FL_PROCEDURE
&& attr->flavor != FL_UNKNOWN)
{
-
a2 = in_namelist;
goto conflict;
}
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)
{
- conf2(pointer);
- conf2(target);
- conf2(allocatable);
- conf2(result);
- conf2(in_namelist);
- conf2(dimension);
- conf2(function);
- conf2(threadprivate);
+ conf2 (pointer);
+ conf2 (target);
+ conf2 (allocatable);
+ conf2 (result);
+ conf2 (in_namelist);
+ conf2 (dimension);
+ conf2 (function);
+ conf2 (threadprivate);
}
switch (attr->proc)
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);
break;
default:
/* Mark a symbol as referenced. */
void
-gfc_set_sym_referenced (gfc_symbol * sym)
+gfc_set_sym_referenced (gfc_symbol *sym)
{
+
if (sym->attr.referenced)
return;
nonzero if not. */
static int
-check_used (symbol_attribute * attr, const char * name, locus * where)
+check_used (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->use_assoc == 0)
/* Generate an error because of a duplicate attribute. */
static void
-duplicate_attr (const char *attr, locus * where)
+duplicate_attr (const char *attr, locus *where)
{
if (where == NULL)
gfc_error ("Duplicate %s attribute specified at %L", attr, where);
}
-/* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
+
+/* Called from decl.c (attr_decl1) to check attributes, when declared
+ separately. */
try
-gfc_add_attribute (symbol_attribute * attr, locus * where)
+gfc_add_attribute (symbol_attribute *attr, locus *where)
{
+
if (check_used (attr, NULL, where))
return FAILURE;
}
try
-gfc_add_allocatable (symbol_attribute * attr, locus * where)
+gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_external (symbol_attribute * attr, locus * where)
+gfc_add_external (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_intrinsic (symbol_attribute * attr, locus * where)
+gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_optional (symbol_attribute * attr, locus * where)
+gfc_add_optional (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_pointer (symbol_attribute * attr, locus * where)
+gfc_add_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
+gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
+gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return check_conflict (attr, NULL, where);
}
+
try
-gfc_add_protected (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return FAILURE;
return check_conflict (attr, name, where);
}
+
try
-gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
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);
}
+
try
-gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return check_conflict (attr, name, where);
}
+
try
-gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
that the local identifier made accessible by a use statement can be
try
-gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
+
if (check_used (attr, name, where))
return FAILURE;
try
-gfc_add_target (symbol_attribute * attr, locus * where)
+gfc_add_target (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}
+
try
-gfc_add_in_equivalence (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
/* Duplicate attribute already checked for. */
try
-gfc_add_in_namelist (symbol_attribute * attr, const char *name,
- locus * where)
+gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
attr->in_namelist = 1;
try
-gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_elemental (symbol_attribute * attr, locus * where)
+gfc_add_elemental (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_pure (symbol_attribute * attr, locus * where)
+gfc_add_pure (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_recursive (symbol_attribute * attr, locus * where)
+gfc_add_recursive (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
try
-gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
try
-gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
try
-gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
+gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
considers attributes and can be reaffirmed multiple times. */
try
-gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
- locus * where)
+gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
+ locus *where)
{
if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
if (where == NULL)
where = &gfc_current_locus;
- gfc_error ("%s attribute conflicts with %s attribute at %L",
- gfc_code2string (flavors, attr->flavor),
- gfc_code2string (flavors, f), where);
+ if (name)
+ gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
+ gfc_code2string (flavors, attr->flavor), name,
+ gfc_code2string (flavors, f), where);
+ else
+ gfc_error ("%s attribute conflicts with %s attribute at %L",
+ gfc_code2string (flavors, attr->flavor),
+ gfc_code2string (flavors, f), where);
return FAILURE;
}
try
-gfc_add_procedure (symbol_attribute * attr, procedure_type t,
- const char *name, locus * where)
+gfc_add_procedure (symbol_attribute *attr, procedure_type t,
+ const char *name, locus *where)
{
if (check_used (attr, name, where))
try
-gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
+gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
if (check_used (attr, NULL, where))
/* No checks for use-association in public and private statements. */
try
-gfc_add_access (symbol_attribute * attr, gfc_access access,
- const char *name, locus * where)
+gfc_add_access (symbol_attribute *attr, gfc_access access,
+ const char *name, locus *where)
{
if (attr->access == ACCESS_UNKNOWN)
}
+/* Set the is_bind_c field for the given symbol_attribute. */
+
+try
+gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
+ int is_proc_lang_bind_spec)
+{
+
+ if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", where);
+ else if (attr->is_bind_c)
+ gfc_error_now ("Duplicate BIND attribute specified at %L", where);
+ else
+ attr->is_bind_c = 1;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
+ == FAILURE)
+ return FAILURE;
+
+ return check_conflict (attr, name, where);
+}
+
+
try
-gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
- gfc_formal_arglist * formal, locus * where)
+gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist * formal, locus *where)
{
if (check_used (&sym->attr, sym->name, where))
/* Add a type to a symbol. */
try
-gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
+gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
{
const char *msg = "Symbol '%s' at %L already has basic type of %s";
if (!(sym->ts.type == ts->type
- && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
- || gfc_notification_std (GFC_STD_GNU) == ERROR
- || pedantic)
+ && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
+ || gfc_notification_std (GFC_STD_GNU) == ERROR
+ || pedantic)
{
gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
return FAILURE;
}
else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
gfc_basic_typename (sym->ts.type)) == FAILURE)
- return FAILURE;
+ return FAILURE;
}
flavor = sym->attr.flavor;
if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
- || flavor == FL_LABEL || (flavor == FL_PROCEDURE
- && sym->attr.subroutine)
+ || flavor == FL_LABEL
+ || (flavor == FL_PROCEDURE && sym->attr.subroutine)
|| flavor == FL_DERIVED || flavor == FL_NAMELIST)
{
gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
/* Clears all attributes. */
void
-gfc_clear_attr (symbol_attribute * attr)
+gfc_clear_attr (symbol_attribute *attr)
{
- memset (attr, 0, sizeof(symbol_attribute));
+ memset (attr, 0, sizeof (symbol_attribute));
}
nothing, but it's not clear that it is unnecessary yet. */
try
-gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
- locus * where ATTRIBUTE_UNUSED)
+gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
+ locus *where ATTRIBUTE_UNUSED)
{
return SUCCESS;
where we are called from, so we ignore some bits. */
try
-gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
+gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
-
+ int is_proc_lang_bind_spec;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
goto fail;
if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
goto fail;
- if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
+ if (src->threadprivate
+ && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
goto fail;
if (src->target && gfc_add_target (dest, where) == FAILURE)
goto fail;
goto fail;
if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
goto fail;
+
+ is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
+ if (src->is_bind_c
+ && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
+ != SUCCESS)
+ return FAILURE;
+
+ if (src->is_c_interop)
+ dest->is_c_interop = 1;
+ if (src->is_iso_c)
+ dest->is_iso_c = 1;
- /* The subroutines that set these bits also cause flavors to be set,
- and that has already happened in the original, so don't let it
- happen again. */
- if (src->external)
- dest->external = 1;
- if (src->intrinsic)
- dest->intrinsic = 1;
+ if (src->external && gfc_add_external (dest, where) == FAILURE)
+ goto fail;
+ if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
+ goto fail;
return SUCCESS;
point to the additional component structure. */
try
-gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
+gfc_add_component (gfc_symbol *sym, const char *name,
+ gfc_component **component)
{
gfc_component *p, *tail;
namespace. */
static void
-switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
+switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
{
gfc_symbol *sym;
is no translation and we return the node we were passed. */
gfc_symbol *
-gfc_use_derived (gfc_symbol * sym)
+gfc_use_derived (gfc_symbol *sym)
{
gfc_symbol *s;
gfc_typespec *t;
not found or the components are private. */
gfc_component *
-gfc_find_component (gfc_symbol * sym, const char *name)
+gfc_find_component (gfc_symbol *sym, const char *name)
{
gfc_component *p;
name, sym->name);
else
{
- if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
+ if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
+ || p->access == ACCESS_PRIVATE))
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
they point to. */
static void
-free_components (gfc_component * p)
+free_components (gfc_component *p)
{
gfc_component *q;
}
-/* Set component attributes from a standard symbol attribute
- structure. */
+/* Set component attributes from a standard symbol attribute structure. */
void
-gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
+gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
{
c->dimension = attr->dimension;
c->pointer = attr->pointer;
c->allocatable = attr->allocatable;
+ c->access = attr->access;
}
structure. */
void
-gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
+gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
{
gfc_clear_attr (attr);
attr->dimension = c->dimension;
attr->pointer = c->pointer;
attr->allocatable = c->allocatable;
+ attr->access = c->access;
}
binary tree. */
static int
-compare_st_labels (void * a1, void * b1)
+compare_st_labels (void *a1, void *b1)
{
- int a = ((gfc_st_label *)a1)->value;
- int b = ((gfc_st_label *)b1)->value;
+ int a = ((gfc_st_label *) a1)->value;
+ int b = ((gfc_st_label *) b1)->value;
return (b - a);
}
occurs. */
void
-gfc_free_st_label (gfc_st_label * label)
+gfc_free_st_label (gfc_st_label *label)
{
+
if (label == NULL)
return;
gfc_free (label);
}
+
/* Free a whole tree of gfc_st_label structures. */
static void
-free_st_labels (gfc_st_label * label)
+free_st_labels (gfc_st_label *label)
{
+
if (label == NULL)
return;
correctly. */
void
-gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
+gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
{
int labelno;
wrong. */
try
-gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
+gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
gfc_sl_type label_type;
int labelno;
}
+/*******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
PARENT if PARENT_TYPES is set. */
gfc_namespace *
-gfc_get_namespace (gfc_namespace * parent, int parent_types)
+gfc_get_namespace (gfc_namespace *parent, int parent_types)
{
gfc_namespace *ns;
gfc_typespec *ts;
if (parent_types && ns->parent != NULL)
{
- /* Copy parent settings */
+ /* Copy parent settings. */
*ts = ns->parent->default_type[i - 'a'];
continue;
}
/* Comparison function for symtree nodes. */
static int
-compare_symtree (void * _st1, void * _st2)
+compare_symtree (void *_st1, void *_st2)
{
gfc_symtree *st1, *st2;
/* Allocate a new symtree node and associate it with the new symbol. */
gfc_symtree *
-gfc_new_symtree (gfc_symtree ** root, const char *name)
+gfc_new_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree *st;
/* Delete a symbol from the tree. Does not free the symbol itself! */
static void
-delete_symtree (gfc_symtree ** root, const char *name)
+delete_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree st, *st0;
the namespace. Returns NULL if the symbol is not found. */
gfc_symtree *
-gfc_find_symtree (gfc_symtree * st, const char *name)
+gfc_find_symtree (gfc_symtree *st, const char *name)
{
int c;
not exist. */
gfc_user_op *
-gfc_find_uop (const char *name, gfc_namespace * ns)
+gfc_find_uop (const char *name, gfc_namespace *ns)
{
gfc_symtree *st;
/* Remove a gfc_symbol structure and everything it points to. */
void
-gfc_free_symbol (gfc_symbol * sym)
+gfc_free_symbol (gfc_symbol *sym)
{
if (sym == NULL)
/* Allocate and initialize a new symbol node. */
gfc_symbol *
-gfc_new_symbol (const char *name, gfc_namespace * ns)
+gfc_new_symbol (const char *name, gfc_namespace *ns)
{
gfc_symbol *p;
gfc_internal_error ("new_symbol(): Symbol name too long");
p->name = gfc_get_string (name);
+
+ /* Make sure flags for symbol being C bound are clear initially. */
+ p->attr.is_bind_c = 0;
+ p->attr.is_iso_c = 0;
+ /* Make sure the binding label field has a Nul char to start. */
+ p->binding_label[0] = '\0';
+
+ /* Clear the ptrs we may need. */
+ p->common_block = NULL;
+
return p;
}
/* Generate an error if a symbol is ambiguous. */
static void
-ambiguous_symbol (const char *name, gfc_symtree * st)
+ambiguous_symbol (const char *name, gfc_symtree *st)
{
if (st->n.sym->module)
Returns nonzero if the name is ambiguous. */
int
-gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
- gfc_symtree ** result)
+gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
+ gfc_symtree **result)
{
gfc_symtree *st;
/* Same, but returns the symbol instead. */
int
-gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
- gfc_symbol ** result)
+gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
+ gfc_symbol **result)
{
gfc_symtree *st;
int i;
/* Save symbol with the information necessary to back it out. */
static void
-save_symbol_data (gfc_symbol * sym)
+save_symbol_data (gfc_symbol *sym)
{
if (sym->new || sym->old_symbol != NULL)
So if the return value is nonzero, then an error was issued. */
int
-gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
{
gfc_symtree *st;
gfc_symbol *p;
int
-gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
+gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
{
gfc_symtree *st;
int i;
-
i = gfc_get_sym_tree (name, ns, &st);
if (i != 0)
return i;
exist, but tries to host-associate the symbol if possible. */
int
-gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
+gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
{
gfc_symtree *st;
int i;
if (st != NULL)
{
save_symbol_data (st->n.sym);
-
*result = st;
return i;
}
int
-gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
+gfc_get_ha_symbol (const char *name, gfc_symbol **result)
{
int i;
gfc_symtree *st;
not take account of aliasing due to equivalence statements. */
int
-gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
+gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
{
/* Aliasing isn't possible if the symbols have different base types. */
if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
}
else
{
-
if (p->namelist_tail != old->namelist_tail)
{
gfc_free_namelist (old->namelist_tail);
because sym->namelist has gotten a few more items. */
static void
-free_old_symbol (gfc_symbol * sym)
+free_old_symbol (gfc_symbol *sym)
{
+
if (sym->old_symbol == NULL)
return;
p->tlink = NULL;
p->mark = 0;
p->new = 0;
-
free_old_symbol (p);
}
changed_syms = NULL;
information. */
void
-gfc_commit_symbol (gfc_symbol * sym)
+gfc_commit_symbol (gfc_symbol *sym)
{
gfc_symbol *p;
operator nodes that it contains. */
static void
-free_uop_tree (gfc_symtree * uop_tree)
+free_uop_tree (gfc_symtree *uop_tree)
{
if (uop_tree == NULL)
that it contains. */
static void
-free_sym_tree (gfc_symtree * sym_tree)
+free_sym_tree (gfc_symtree *sym_tree)
{
gfc_namespace *ns;
gfc_symbol *sym;
/* Free the gfc_equiv_info's. */
static void
-gfc_free_equiv_infos (gfc_equiv_info * s)
+gfc_free_equiv_infos (gfc_equiv_info *s)
{
if (s == NULL)
return;
/* Free the gfc_equiv_lists. */
static void
-gfc_free_equiv_lists (gfc_equiv_list * l)
+gfc_free_equiv_lists (gfc_equiv_list *l)
{
if (l == NULL)
return;
taken care of when a specific name is freed. */
void
-gfc_free_namespace (gfc_namespace * ns)
+gfc_free_namespace (gfc_namespace *ns)
{
gfc_charlen *cl, *cl2;
gfc_namespace *p, *q;
{
q = p;
p = p->sibling;
-
gfc_free_namespace (q);
}
}
/* Clear mark bits from symbol nodes associated with a symtree node. */
static void
-clear_sym_mark (gfc_symtree * st)
+clear_sym_mark (gfc_symtree *st)
{
st->n.sym->mark = 0;
/* Recursively traverse the symtree nodes. */
void
-gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
+gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
{
if (st != NULL)
{
/* Recursive namespace traversal function. */
static void
-traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
+traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
{
if (st == NULL)
care that each gfc_symbol node is called exactly once. */
void
-gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
+gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
{
gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
/* Return TRUE if the symbol is an automatic variable. */
+
static bool
-gfc_is_var_automatic (gfc_symbol * sym)
+gfc_is_var_automatic (gfc_symbol *sym)
{
/* Pointer and allocatable variables are never automatic. */
if (sym->attr.pointer || sym->attr.allocatable)
/* Given a symbol, mark it as SAVEd if it is allowed. */
static void
-save_symbol (gfc_symbol * sym)
+save_symbol (gfc_symbol *sym)
{
if (sym->attr.use_assoc)
/* Mark those symbols which can be SAVEd as such. */
void
-gfc_save_all (gfc_namespace * ns)
+gfc_save_all (gfc_namespace *ns)
{
gfc_traverse_ns (ns, save_symbol);
/* Compare two global symbols. Used for managing the BB tree. */
static int
-gsym_compare (void * _s1, void * _s2)
+gsym_compare (void *_s1, void *_s2)
{
gfc_gsymbol *s1, *s2;
- s1 = (gfc_gsymbol *)_s1;
- s2 = (gfc_gsymbol *)_s2;
- return strcmp(s1->name, s2->name);
+ s1 = (gfc_gsymbol *) _s1;
+ s2 = (gfc_gsymbol *) _s2;
+ return strcmp (s1->name, s2->name);
}
return s;
}
+
+
+static gfc_symbol *
+get_iso_c_binding_dt (int sym_id)
+{
+ gfc_dt_list *dt_list;
+
+ dt_list = gfc_derived_types;
+
+ /* Loop through the derived types in the name list, searching for
+ the desired symbol from iso_c_binding. Search the parent namespaces
+ if necessary and requested to (parent_flag). */
+ while (dt_list != NULL)
+ {
+ if (dt_list->derived->from_intmod != INTMOD_NONE
+ && dt_list->derived->intmod_sym_id == sym_id)
+ return dt_list->derived;
+
+ dt_list = dt_list->next;
+ }
+
+ return NULL;
+}
+
+
+/* Verifies that the given derived type symbol, derived_sym, is interoperable
+ with C. This is necessary for any derived type that is BIND(C) and for
+ derived types that are parameters to functions that are BIND(C). All
+ fields of the derived type are required to be interoperable, and are tested
+ for such. If an error occurs, the errors are reported here, allowing for
+ multiple errors to be handled for a single derived type. */
+
+try
+verify_bind_c_derived_type (gfc_symbol *derived_sym)
+{
+ gfc_component *curr_comp = NULL;
+ try is_c_interop = FAILURE;
+ try retval = SUCCESS;
+
+ if (derived_sym == NULL)
+ gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
+ "unexpectedly NULL");
+
+ /* If we've already looked at this derived symbol, do not look at it again
+ so we don't repeat warnings/errors. */
+ if (derived_sym->ts.is_c_interop)
+ return SUCCESS;
+
+ /* The derived type must have the BIND attribute to be interoperable
+ J3/04-007, Section 15.2.3. */
+ if (derived_sym->attr.is_bind_c != 1)
+ {
+ derived_sym->ts.is_c_interop = 0;
+ gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
+ "attribute to be C interoperable", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ curr_comp = derived_sym->components;
+
+ /* TODO: is this really an error? */
+ if (curr_comp == NULL)
+ {
+ gfc_error ("Derived type '%s' at %L is empty",
+ derived_sym->name, &(derived_sym->declared_at));
+ return FAILURE;
+ }
+
+ /* Initialize the derived type as being C interoperable.
+ If we find an error in the components, this will be set false. */
+ derived_sym->ts.is_c_interop = 1;
+
+ /* Loop through the list of components to verify that the kind of
+ each is a C interoperable type. */
+ do
+ {
+ /* The components cannot be pointers (fortran sense).
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->pointer != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "POINTER attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* The components cannot be allocatable.
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->allocatable != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "ALLOCATABLE attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* BIND(C) derived types must have interoperable components. */
+ if (curr_comp->ts.type == BT_DERIVED
+ && curr_comp->ts.derived->ts.is_iso_c != 1
+ && curr_comp->ts.derived != derived_sym)
+ {
+ /* This should be allowed; the draft says a derived-type can not
+ have type parameters if it is has the BIND attribute. Type
+ parameters seem to be for making parameterized derived types.
+ There's no need to verify the type if it is c_ptr/c_funptr. */
+ retval = verify_bind_c_derived_type (curr_comp->ts.derived);
+ }
+ else
+ {
+ /* Grab the typespec for the given component and test the kind. */
+ is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
+ &(curr_comp->loc));
+
+ if (is_c_interop != SUCCESS)
+ {
+ /* Report warning and continue since not fatal. The
+ draft does specify a constraint that requires all fields
+ to interoperate, but if the user says real(4), etc., it
+ may interoperate with *something* in C, but the compiler
+ most likely won't know exactly what. Further, it may not
+ interoperate with the same data type(s) in C if the user
+ recompiles with different flags (e.g., -m32 and -m64 on
+ x86_64 and using integer(4) to claim interop with a
+ C_LONG). */
+ if (derived_sym->attr.is_bind_c == 1)
+ /* If the derived type is bind(c), all fields must be
+ interop. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable, even though "
+ "derived type '%s' is BIND(C)",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc), derived_sym->name);
+ else
+ /* If derived type is param to bind(c) routine, or to one
+ of the iso_c_binding procs, it must be interoperable, so
+ all fields must interop too. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc));
+ }
+ }
+
+ curr_comp = curr_comp->next;
+ } while (curr_comp != NULL);
+
+
+ /* Make sure we don't have conflicts with the attributes. */
+ if (derived_sym->attr.access == ACCESS_PRIVATE)
+ {
+ gfc_error ("Derived type '%s' at %L cannot be declared with both "
+ "PRIVATE and BIND(C) attributes", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ if (derived_sym->attr.sequence != 0)
+ {
+ gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
+ "attribute because it is BIND(C)", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* Mark the derived type as not being C interoperable if we found an
+ error. If there were only warnings, proceed with the assumption
+ it's interoperable. */
+ if (retval == FAILURE)
+ derived_sym->ts.is_c_interop = 0;
+
+ return retval;
+}
+
+
+/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
+
+static try
+gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
+ const char *module_name)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *tmp_sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
+
+ if (tmp_symtree != NULL)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ {
+ tmp_sym = NULL;
+ gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
+ "create symbol for %s", ptr_name);
+ }
+
+ /* Set up the symbol's important fields. Save attr required so we can
+ initialize the ptr to NULL. */
+ 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;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* The c_ptr and c_funptr derived types will provide the
+ definition for c_null_ptr and c_null_funptr, respectively. */
+ if (ptr_id == ISOCBINDING_NULL_PTR)
+ tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.derived == NULL)
+ {
+ /* This can occur if the user forgot to declare c_ptr or
+ c_funptr and they're trying to use one of the procedures
+ that has arg(s) of the missing type. In this case, a
+ regular version of the thing should have been put in the
+ current ns. */
+ generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
+ (const char *) (ptr_id == ISOCBINDING_NULL_PTR
+ ? "_gfortran_iso_c_binding_c_ptr"
+ : "_gfortran_iso_c_binding_c_funptr"));
+
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+ }
+
+ /* Module name is some mangled version of iso_c_binding. */
+ tmp_sym->module = gfc_get_string (module_name);
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ tmp_sym->attr.use_assoc = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ /* Set the binding_label. */
+ sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+
+ /* Set the c_address field of c_null_ptr and c_null_funptr to
+ the value of NULL. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_STRUCTURE;
+ tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ 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;
+
+ return SUCCESS;
+}
+
+
+/* Add a formal argument, gfc_formal_arglist, to the
+ end of the given list of arguments. Set the reference to the
+ provided symbol, param_sym, in the argument. */
+
+static void
+add_formal_arg (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ gfc_formal_arglist *formal_arg,
+ gfc_symbol *param_sym)
+{
+ /* Put in list, either as first arg or at the tail (curr arg). */
+ if (*head == NULL)
+ *head = *tail = formal_arg;
+ else
+ {
+ (*tail)->next = formal_arg;
+ (*tail) = formal_arg;
+ }
+
+ (*tail)->sym = param_sym;
+ (*tail)->next = NULL;
+
+ return;
+}
+
+
+/* Generates a symbol representing the CPTR argument to an
+ iso_c_binding procedure. Also, create a gfc_formal_arglist for the
+ CPTR and add it to the provided argument list. */
+
+static void
+gen_cptr_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_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 = 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__";
+ else
+ c_ptr_in = c_ptr_name;
+ gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("gen_cptr_param(): Unable to "
+ "create symbol for %s", c_ptr_in);
+
+ /* Set up the appropriate fields for the new c_ptr param sym. */
+ param_sym->refs++;
+ param_sym->attr.flavor = FL_DERIVED;
+ param_sym->ts.type = BT_DERIVED;
+ param_sym->attr.intent = INTENT_IN;
+ param_sym->attr.dummy = 1;
+
+ /* This will pass the ptr to the iso_c routines as a (void *). */
+ param_sym->attr.value = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* 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. */
+ 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->ts.derived = c_ptr_sym;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make new formal arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args (the CPTR arg). */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+
+/* Generates a symbol representing the FPTR argument to an
+ iso_c_binding procedure. Also, create a gfc_formal_arglist for the
+ FPTR and add it to the provided argument list. */
+
+static void
+gen_fptr_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_name,
+ gfc_namespace *ns, const char *f_ptr_name)
+{
+ gfc_symbol *param_sym = NULL;
+ gfc_symtree *param_symtree = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ const char *f_ptr_out = "gfc_fptr__";
+
+ if (f_ptr_name != NULL)
+ f_ptr_out = f_ptr_name;
+
+ gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("generateFPtrParam(): Unable to "
+ "create symbol for %s", f_ptr_out);
+
+ /* Set up the necessary fields for the fptr output param sym. */
+ param_sym->refs++;
+ param_sym->attr.pointer = 1;
+ param_sym->attr.dummy = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* ISO C Binding type to allow any pointer type as actual param. */
+ param_sym->ts.type = BT_VOID;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make the arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args. */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+
+/* Generates a symbol representing the optional SHAPE argument for the
+ iso_c_binding c_f_pointer() procedure. Also, create a
+ gfc_formal_arglist for the SHAPE and add it to the provided
+ argument list. */
+
+static void
+gen_shape_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_name,
+ gfc_namespace *ns, const char *shape_param_name)
+{
+ gfc_symbol *param_sym = NULL;
+ gfc_symtree *param_symtree = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ const char *shape_param = "gfc_shape_array__";
+ int i;
+
+ if (shape_param_name != NULL)
+ shape_param = shape_param_name;
+
+ gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("generateShapeParam(): Unable to "
+ "create symbol for %s", shape_param);
+
+ /* Set up the necessary fields for the shape input param sym. */
+ param_sym->refs++;
+ param_sym->attr.dummy = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* 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 ();
+
+ /* Clear out the dimension info for the array. */
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ param_sym->as->lower[i] = NULL;
+ param_sym->as->upper[i] = NULL;
+ }
+ param_sym->as->rank = 1;
+ param_sym->as->lower[0] = gfc_int_expr (1);
+
+ /* The extent is unknown until we get it. The length give us
+ the rank the incoming pointer. */
+ param_sym->as->type = AS_ASSUMED_SHAPE;
+
+ /* The arg is also optional; it is required iff the second arg
+ (fptr) is to an array, otherwise, it's ignored. */
+ param_sym->attr.optional = 1;
+ param_sym->attr.intent = INTENT_IN;
+ param_sym->attr.dimension = 1;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make the arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args. */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+/* Add a procedure interface to the given symbol (i.e., store a
+ reference to the list of formal arguments). */
+
+static void
+add_proc_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist *formal)
+{
+
+ sym->formal = formal;
+ sym->attr.if_source = source;
+}
+
+
+/* Builds the parameter list for the iso_c_binding procedure
+ c_f_pointer or c_f_procpointer. The old_sym typically refers to a
+ generic version of either the c_f_pointer or c_f_procpointer
+ functions. The new_proc_sym represents a "resolved" version of the
+ symbol. The functions are resolved to match the types of their
+ parameters; for example, c_f_pointer(cptr, fptr) would resolve to
+ something similar to c_f_pointer_i4 if the type of data object fptr
+ pointed to was a default integer. The actual name of the resolved
+ procedure symbol is further mangled with the module name, etc., but
+ the idea holds true. */
+
+static void
+build_formal_args (gfc_symbol *new_proc_sym,
+ gfc_symbol *old_sym, int add_optional_arg)
+{
+ gfc_formal_arglist *head = NULL, *tail = NULL;
+ gfc_namespace *parent_ns = NULL;
+
+ 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 = new_proc_sym;
+
+ /* Generate the params. */
+ if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
+ (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");
+
+ /* 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");
+ }
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ /* 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", ISOCBINDING_ASSOCIATED);
+ if (add_optional_arg)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
+ /* The last param is optional so mark it as such. */
+ tail->sym->attr.optional = 1;
+ }
+ }
+
+ /* Add the interface (store formal args to new_proc_sym). */
+ add_proc_interface (new_proc_sym, IFSRC_DECL, head);
+
+ /* Set up the formal_ns pointer to the one created for the
+ new procedure so it'll get cleaned up during gfc_free_symbol(). */
+ new_proc_sym->formal_ns = gfc_current_ns;
+
+ gfc_current_ns = parent_ns;
+}
+
+
+/* Generate the given set of C interoperable kind objects, or all
+ interoperable kinds. This function will only be given kind objects
+ for valid iso_c_binding defined types because this is verified when
+ the 'use' statement is parsed. If the user gives an 'only' clause,
+ the specific kinds are looked up; if they don't exist, an error is
+ reported. If the user does not give an 'only' clause, all
+ iso_c_binding symbols are generated. If a list of specific kinds
+ is given, it must have a NULL in the first empty spot to mark the
+ end of the list. */
+
+
+void
+generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
+ const char *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;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
+ char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
+ int index;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+ /* Already exists in this scope so don't re-add it.
+ TODO: we should probably check that it's really the same symbol. */
+ if (tmp_symtree != NULL)
+ return;
+
+ /* Create the sym tree in the current ns. */
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ if (tmp_symtree)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create symbol");
+
+ /* Say what module this symbol belongs to. */
+ tmp_sym->module = gfc_get_string (mod_name);
+ tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ tmp_sym->intmod_sym_id = s;
+
+ switch (s)
+ {
+
+#define NAMED_INTCST(a,b,c) 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 :
+#define NAMED_CHARKNDCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_INTEGER;
+ tmp_sym->ts.kind = gfc_default_integer_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->attr.is_c_interop = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+
+#define NAMED_CHARCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ /* Initialize an integer constant expression node for the
+ length of the character. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_CONSTANT;
+ tmp_sym->value->ts.type = BT_CHARACTER;
+ tmp_sym->value->ts.kind = gfc_default_character_kind;
+ tmp_sym->value->where = gfc_current_locus;
+ 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[0]
+ = (char) c_interop_kinds_table[s].value;
+ tmp_sym->value->value.character.string[1] = '\0';
+
+ /* May not need this in both attr and ts, but do need in
+ attr for writing module file. */
+ tmp_sym->attr.is_c_interop = 1;
+
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_CHARACTER;
+
+ /* Need to set it to the C_CHAR kind. */
+ tmp_sym->ts.kind = gfc_default_character_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = BT_CHARACTER;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_DERIVED;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ tmp_sym->attr.is_bind_c = 1;
+
+ tmp_sym->attr.referenced = 1;
+
+ tmp_sym->ts.derived = tmp_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ dt_list_ptr = &(gfc_derived_types);
+ while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+
+ /* There is already at least one derived type in the list, so append
+ the one we're currently building for c_ptr or c_funptr. */
+ if (*dt_list_ptr != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+ (*dt_list_ptr) = gfc_get_dt_list ();
+ (*dt_list_ptr)->derived = tmp_sym;
+ (*dt_list_ptr)->next = NULL;
+
+ /* Set up the component of the derived type, which will be
+ an integer with kind equal to c_ptr_size. Mangle the name of
+ the field for the c_address to prevent the curious user from
+ trying to access it from Fortran. */
+ sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
+ gfc_add_component (tmp_sym, comp_name, &tmp_comp);
+ if (tmp_comp == NULL)
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create component for c_address");
+
+ tmp_comp->ts.type = BT_INTEGER;
+
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
+
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+
+ tmp_comp->pointer = 0;
+ tmp_comp->dimension = 0;
+
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+
+ /* Make it use associated (iso_c_binding module). */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_NULL_PTR:
+ case ISOCBINDING_NULL_FUNPTR:
+ gen_special_c_interop_ptr (s, name, mod_name);
+ break;
+
+ case ISOCBINDING_F_POINTER:
+ case ISOCBINDING_ASSOCIATED:
+ case ISOCBINDING_LOC:
+ case ISOCBINDING_FUNLOC:
+ case ISOCBINDING_F_PROCPOINTER:
+
+ tmp_sym->attr.proc = PROC_MODULE;
+
+ /* Use the procedure's name as it is in the iso_c_binding module for
+ setting the binding label in case the user renamed the symbol. */
+ sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
+ c_interop_kinds_table[s].name);
+ tmp_sym->attr.is_iso_c = 1;
+ if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
+ tmp_sym->attr.subroutine = 1;
+ else
+ {
+ /* TODO! This needs to be finished more for the expr of the
+ function or something!
+ This may not need to be here, because trying to do c_loc
+ as an external. */
+ if (s == ISOCBINDING_ASSOCIATED)
+ {
+ tmp_sym->attr.function = 1;
+ tmp_sym->ts.type = BT_LOGICAL;
+ tmp_sym->ts.kind = gfc_default_logical_kind;
+ tmp_sym->result = tmp_sym;
+ }
+ else
+ {
+ /* Here, we're taking the simple approach. We're defining
+ c_loc as an external identifier so the compiler will put
+ what we expect on the stack for the address we want the
+ C address of. */
+ tmp_sym->ts.type = BT_DERIVED;
+ if (s == ISOCBINDING_LOC)
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+
+ if (tmp_sym->ts.derived == NULL)
+ {
+ /* Create the necessary derived type so we can continue
+ processing the file. */
+ generate_isocbinding_symbol
+ (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 =
+ get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR
+ : ISOCBINDING_PTR);
+ }
+
+ /* The function result is itself (no result clause). */
+ tmp_sym->result = tmp_sym;
+ tmp_sym->attr.external = 1;
+ tmp_sym->attr.use_assoc = 0;
+ tmp_sym->attr.if_source = IFSRC_UNKNOWN;
+ tmp_sym->attr.proc = PROC_UNKNOWN;
+ }
+ }
+
+ tmp_sym->attr.flavor = FL_PROCEDURE;
+ tmp_sym->attr.contained = 0;
+
+ /* Try using this builder routine, with the new and old symbols
+ both being the generic iso_c proc sym being created. This
+ will create the formal args (and the new namespace for them).
+ Don't build an arg list for c_loc because we're going to treat
+ c_loc as an external procedure. */
+ if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
+ /* The 1 says to add any optional args, if applicable. */
+ build_formal_args (tmp_sym, tmp_sym, 1);
+
+ /* Set this after setting up the symbol, to prevent error messages. */
+ tmp_sym->attr.use_assoc = 1;
+
+ /* This symbol will not be referenced directly. It will be
+ resolved to the implementation for the given f90 kind. */
+ tmp_sym->attr.referenced = 0;
+
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+/* Creates a new symbol based off of an old iso_c symbol, with a new
+ binding label. This function can be used to create a new,
+ resolved, version of a procedure symbol for c_f_pointer or
+ c_f_procpointer that is based on the generic symbols. A new
+ parameter list is created for the new symbol using
+ build_formal_args(). The add_optional_flag specifies whether the
+ to add the optional SHAPE argument. The new symbol is
+ returned. */
+
+gfc_symbol *
+get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
+ char *new_binding_label, int add_optional_arg)
+{
+ gfc_symtree *new_symtree = NULL;
+
+ /* See if we have a symbol by that name already available, looking
+ through any parent namespaces. */
+ gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
+ if (new_symtree != NULL)
+ /* Return the existing symbol. */
+ return new_symtree->n.sym;
+
+ /* Create the symtree/symbol, with attempted host association. */
+ gfc_get_ha_sym_tree (new_name, &new_symtree);
+ if (new_symtree == NULL)
+ gfc_internal_error ("get_iso_c_sym(): Unable to create "
+ "symtree for '%s'", new_name);
+
+ /* Now fill in the fields of the resolved symbol with the old sym. */
+ strcpy (new_symtree->n.sym->binding_label, new_binding_label);
+ 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);
+ /* Build the formal arg list. */
+ build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
+
+ gfc_commit_symbol (new_symtree->n.sym);
+
+ return new_symtree->n.sym;
+}
+