/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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 "config.h"
#include "system.h"
+#include "flags.h"
#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. */
static gfc_symbol *changed_syms = NULL;
+gfc_dt_list *gfc_derived_types;
+
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
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;
letter = sym->name[0];
+
+ if (gfc_option.flag_allow_leading_underscore && letter == '_')
+ gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
+ "gfortran developers, and should not be used for "
+ "implicitly typed variables");
+
if (letter < 'a' || letter > 'z')
gfc_internal_error ("gfc_get_default_type(): Bad symbol");
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;
}
+/* This function is called from parse.c(parse_progunit) to check the
+ type of the function is not implicitly typed in the host namespace
+ and to implicitly type the function result, if necessary. */
+
+void
+gfc_check_function_type (gfc_namespace *ns)
+{
+ gfc_symbol *proc = ns->proc_name;
+
+ if (!proc->attr.contained || proc->result->attr.implicit_type)
+ return;
+
+ if (proc->result->ts.type == BT_UNKNOWN)
+ {
+ if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
+ == SUCCESS)
+ {
+ if (proc->result != proc)
+ {
+ 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 ("Function result '%s' at %L has no IMPLICIT type",
+ proc->result->name, &proc->result->declared_at);
+ proc->result->attr.untyped = 1;
+ }
+ }
+}
+
+
/******************** Symbol attribute stuff *********************/
/* This is a generic conflict-checker. We do this to avoid having a
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
+#define conf_std(a, b, std) if (attr->a && attr->b)\
+ {\
+ a1 = a;\
+ a2 = b;\
+ standard = std;\
+ goto conflict_std;\
+ }
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",
- *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
- *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
+ *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+ *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
+ *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
+ *private = "PRIVATE", *recursive = "RECURSIVE",
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
*public = "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";
+ *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+ *volatile_ = "VOLATILE", *protected = "PROTECTED",
+ *is_bind_c = "BIND(C)";
+ static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
+ int standard;
if (where == NULL)
where = &gfc_current_locus;
{
a1 = pointer;
a2 = intent;
- goto conflict;
+ standard = GFC_STD_F2003;
+ goto conflict_std;
}
/* Check for attributes not allowed in a BLOCK DATA. */
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;
}
}
- conf (dummy, save);
+ 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, threadprivate);
conf (pointer, target);
- conf (pointer, external);
conf (pointer, intrinsic);
+ conf (pointer, elemental);
+ conf (allocatable, elemental);
+
conf (target, external);
conf (target, intrinsic);
conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
+
+ if (attr->if_source || attr->contained)
+ {
+ conf (external, subroutine);
+ conf (external, function);
+ }
+
conf (allocatable, pointer);
- conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
- conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
- conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
+ conf_std (allocatable, dummy, GFC_STD_F2003);
+ conf_std (allocatable, function, GFC_STD_F2003);
+ conf_std (allocatable, result, GFC_STD_F2003);
conf (elemental, recursive);
conf (in_common, dummy);
conf (in_common, allocatable);
conf (in_common, result);
- conf (in_common, save);
- conf (result, save);
conf (dummy, result);
conf (in_equivalence, result);
conf (in_equivalence, entry);
conf (in_equivalence, allocatable);
+ conf (in_equivalence, threadprivate);
conf (in_namelist, pointer);
conf (in_namelist, allocatable);
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 (cray_pointee, optional);
conf (cray_pointee, dummy);
conf (cray_pointee, target);
- conf (cray_pointee, external);
conf (cray_pointee, intrinsic);
conf (cray_pointee, pointer);
- conf (cray_pointee, function);
- conf (cray_pointee, subroutine);
conf (cray_pointee, entry);
conf (cray_pointee, in_common);
conf (cray_pointee, in_equivalence);
+ conf (cray_pointee, threadprivate);
+
+ conf (data, dummy);
+ conf (data, function);
+ conf (data, result);
+ conf (data, allocatable);
+ conf (data, use_assoc);
+
+ conf (value, pointer)
+ conf (value, allocatable)
+ conf (value, subroutine)
+ conf (value, function)
+ conf (value, volatile_)
+ conf (value, dimension)
+ conf (value, external)
+
+ 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->volatile_ && attr->intent == INTENT_IN)
+ {
+ a1 = volatile_;
+ a2 = intent_in;
+ goto conflict;
+ }
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
&& attr->flavor != FL_VARIABLE
+ && attr->flavor != FL_PROCEDURE
&& attr->flavor != FL_UNKNOWN)
{
-
a2 = in_namelist;
goto conflict;
}
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
+ conf2 (dimension);
conf2 (dummy);
- conf2 (save);
+ conf2 (volatile_);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
conf2 (optional);
conf2 (function);
conf2 (subroutine);
+ conf2 (threadprivate);
break;
case FL_VARIABLE:
if (attr->subroutine)
{
- conf2(save);
- conf2(pointer);
- conf2(target);
- conf2(allocatable);
- conf2(result);
- conf2(in_namelist);
- conf2(function);
+ 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;
default:
case FL_DERIVED:
conf2 (dummy);
- conf2 (save);
conf2 (pointer);
conf2 (target);
conf2 (external);
conf2 (entry);
conf2 (function);
conf2 (subroutine);
+ conf2 (threadprivate);
if (attr->intent != INTENT_UNKNOWN)
{
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
- conf2 (save);
+ conf2 (value);
+ conf2 (volatile_);
+ conf2 (threadprivate);
+ /* TODO: hmm, double check this. */
+ conf2 (value);
break;
default:
a1, a2, name, where);
return FAILURE;
+
+conflict_std:
+ if (name == NULL)
+ {
+ return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ "with %s attribute at %L", a1, a2,
+ where);
+ }
+ else
+ {
+ return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ "with %s attribute in '%s' at %L",
+ a1, a2, name, where);
+ }
}
#undef conf
#undef conf2
+#undef conf_std
/* 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)
}
-/* Used to prevent changing the attributes of a symbol after it has been
- used. This check is only done for dummy variables as only these can be
- used in specification expressions. Applying this to all symbols causes
- an error when we reach the body of a contained function. */
+/* Generate an error because of a duplicate attribute. */
-static int
-check_done (symbol_attribute * attr, locus * where)
+static void
+duplicate_attr (const char *attr, locus *where)
{
- if (!(attr->dummy && attr->referenced))
- return 0;
-
if (where == NULL)
where = &gfc_current_locus;
- gfc_error ("Cannot change attributes of symbol at %L"
- " after it has been used", where);
-
- return 1;
+ gfc_error ("Duplicate %s attribute specified at %L", attr, where);
}
-/* Generate an error because of a duplicate attribute. */
+/* Called from decl.c (attr_decl1) to check attributes, when declared
+ separately. */
-static void
-duplicate_attr (const char *attr, locus * where)
+try
+gfc_add_attribute (symbol_attribute *attr, locus *where)
{
- if (where == NULL)
- where = &gfc_current_locus;
+ if (check_used (attr, NULL, where))
+ return FAILURE;
- gfc_error ("Duplicate %s attribute specified at %L", attr, where);
+ return check_conflict (attr, NULL, where);
}
-
try
-gfc_add_allocatable (symbol_attribute * attr, locus * where)
+gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->allocatable)
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) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
if (attr->dimension)
try
-gfc_add_external (symbol_attribute * attr, locus * where)
+gfc_add_external (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->external)
try
-gfc_add_intrinsic (symbol_attribute * attr, locus * where)
+gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->intrinsic)
try
-gfc_add_optional (symbol_attribute * attr, locus * where)
+gfc_add_optional (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->optional)
try
-gfc_add_pointer (symbol_attribute * attr, locus * where)
+gfc_add_pointer (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->pointer = 1;
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) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->cray_pointer = 1;
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) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->cray_pointee)
{
gfc_error ("Cray Pointee at %L appears in multiple pointer()"
- " statements.", where);
+ " statements", where);
return FAILURE;
}
try
-gfc_add_result (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;
+
+ if (attr->protected)
+ {
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate PROTECTED attribute specified at %L",
+ where)
+ == FAILURE)
+ return FAILURE;
+ }
+
+ attr->protected = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+try
+gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
- if (check_used (attr, name, where) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
attr->result = 1;
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)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->value)
+ {
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VALUE attribute specified at %L",
+ where)
+ == FAILURE)
+ return FAILURE;
+ }
+
+ attr->value = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+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
+ that the local identifier made accessible by a use statement can be
+ given a VOLATILE attribute. */
+
+ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VOLATILE attribute specified at %L", where)
+ == FAILURE)
+ return FAILURE;
+
+ attr->volatile_ = 1;
+ attr->volatile_ns = gfc_current_ns;
+ return check_conflict (attr, name, where);
+}
+
+
+try
+gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->threadprivate)
+ {
+ duplicate_attr ("THREADPRIVATE", where);
+ return FAILURE;
+ }
+
+ attr->threadprivate = 1;
return check_conflict (attr, name, where);
}
try
-gfc_add_target (symbol_attribute * attr, locus * where)
+gfc_add_target (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->target)
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) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
/* Duplicate attribute already checked for. */
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) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->elemental = 1;
try
-gfc_add_pure (symbol_attribute * attr, locus * where)
+gfc_add_pure (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->pure = 1;
try
-gfc_add_recursive (symbol_attribute * attr, locus * where)
+gfc_add_recursive (symbol_attribute *attr, locus *where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->recursive = 1;
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) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
if (attr->flavor != FL_PROCEDURE
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;
-/* TODO: This is legal if it is reaffirming an implicit type.
- if (check_done (&sym->attr, where))
- return FAILURE;*/
-
if (where == NULL)
where = &gfc_current_locus;
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
- where, gfc_basic_typename (sym->ts.type));
- return FAILURE;
+ 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)
+ {
+ 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;
}
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->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
+ if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+ goto fail;
+ if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
+ goto fail;
+ if (src->threadprivate
+ && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->target && gfc_add_target (dest, where) == FAILURE)
goto fail;
if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
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, *p;
+ gfc_symbol *s;
gfc_typespec *t;
gfc_symtree *st;
int i;
s->refs++;
/* Unlink from list of modified symbols. */
- if (changed_syms == sym)
- changed_syms = sym->tlink;
- else
- for (p = changed_syms; p; p = p->tlink)
- if (p->tlink == sym)
- {
- p->tlink = sym->tlink;
- break;
- }
+ gfc_commit_symbol (sym);
switch_types (sym->ns->sym_root, sym, s);
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;
}
/******************** Statement label management ********************/
-/* Free a single gfc_st_label structure, making sure the list is not
+/* Comparison function for statement labels, used for managing the
+ binary tree. */
+
+static int
+compare_st_labels (void *a1, void *b1)
+{
+ int a = ((gfc_st_label *) a1)->value;
+ int b = ((gfc_st_label *) b1)->value;
+
+ return (b - a);
+}
+
+
+/* Free a single gfc_st_label structure, making sure the tree is not
messed up. This function is called only when some parse error
occurs. */
void
-gfc_free_st_label (gfc_st_label * l)
+gfc_free_st_label (gfc_st_label *label)
{
- if (l == NULL)
+ if (label == NULL)
return;
- if (l->prev)
- (l->prev->next = l->next);
+ gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
- if (l->next)
- (l->next->prev = l->prev);
+ if (label->format != NULL)
+ gfc_free_expr (label->format);
- if (l->format != NULL)
- gfc_free_expr (l->format);
- gfc_free (l);
+ gfc_free (label);
}
-/* Free a whole list of gfc_st_label structures. */
+
+/* Free a whole tree of gfc_st_label structures. */
static void
-free_st_labels (gfc_st_label * l1)
+free_st_labels (gfc_st_label *label)
{
- gfc_st_label *l2;
- for (; l1; l1 = l2)
- {
- l2 = l1->next;
- if (l1->format != NULL)
- gfc_free_expr (l1->format);
- gfc_free (l1);
- }
+ if (label == NULL)
+ return;
+
+ free_st_labels (label->left);
+ free_st_labels (label->right);
+
+ if (label->format != NULL)
+ gfc_free_expr (label->format);
+ gfc_free (label);
}
gfc_st_label *lp;
/* First see if the label is already in this namespace. */
- for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
- if (lp->value == labelno)
- break;
- if (lp != NULL)
- return lp;
+ lp = gfc_current_ns->st_labels;
+ while (lp)
+ {
+ if (lp->value == labelno)
+ return lp;
+
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
lp = gfc_getmem (sizeof (gfc_st_label));
lp->defined = ST_LABEL_UNKNOWN;
lp->referenced = ST_LABEL_UNKNOWN;
- lp->prev = NULL;
- lp->next = gfc_current_ns->st_labels;
- if (gfc_current_ns->st_labels)
- gfc_current_ns->st_labels->prev = lp;
- gfc_current_ns->st_labels = lp;
+ gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
return lp;
}
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)
gfc_free_namespace (sym->formal_ns);
- gfc_free_interface (sym->generic);
+ if (!sym->attr.generic_copy)
+ gfc_free_interface (sym->generic);
gfc_free_formal_arglist (sym->formal);
/* 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;
if (st != NULL)
{
*result = st;
- if (st->ambiguous)
+ /* Ambiguous generic interfaces are permitted, as long
+ as the specific interfaces are different. */
+ if (st->ambiguous && !st->n.sym->attr.generic)
{
ambiguous_symbol (name, st);
return 1;
/* 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;
}
else
{
- /* Make sure the existing symbol is OK. */
- if (st->ambiguous)
+ /* Make sure the existing symbol is OK. Ambiguous
+ generic interfaces are permitted, as long as the
+ specific interfaces are different. */
+ if (st->ambiguous && !st->n.sym->attr.generic)
{
ambiguous_symbol (name, st);
return 1;
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);
}
+/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
+ components of old_symbol that might need deallocation are the "allocatables"
+ that are restored in gfc_undo_symbols(), with two exceptions: namelist and
+ namelist_tail. In case these differ between old_symbol and sym, it's just
+ because sym->namelist has gotten a few more items. */
+
+static void
+free_old_symbol (gfc_symbol *sym)
+{
+
+ if (sym->old_symbol == NULL)
+ return;
+
+ if (sym->old_symbol->as != sym->as)
+ gfc_free_array_spec (sym->old_symbol->as);
+
+ if (sym->old_symbol->value != sym->value)
+ gfc_free_expr (sym->old_symbol->value);
+
+ if (sym->old_symbol->formal != sym->formal)
+ gfc_free_formal_arglist (sym->old_symbol->formal);
+
+ gfc_free (sym->old_symbol);
+ sym->old_symbol = NULL;
+}
+
+
/* Makes the changes made in the current statement permanent-- gets
rid of undo information. */
p->tlink = NULL;
p->mark = 0;
p->new = 0;
+ free_old_symbol (p);
+ }
+ changed_syms = NULL;
+}
- if (p->old_symbol != NULL)
- {
- gfc_free (p->old_symbol);
- p->old_symbol = NULL;
- }
+
+/* Makes the changes made in one symbol permanent -- gets rid of undo
+ information. */
+
+void
+gfc_commit_symbol (gfc_symbol *sym)
+{
+ gfc_symbol *p;
+
+ if (changed_syms == sym)
+ changed_syms = sym->tlink;
+ else
+ {
+ for (p = changed_syms; p; p = p->tlink)
+ if (p->tlink == sym)
+ {
+ p->tlink = sym->tlink;
+ break;
+ }
}
- changed_syms = NULL;
+ sym->tlink = NULL;
+ sym->mark = 0;
+ sym->new = 0;
+
+ free_old_symbol (sym);
}
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 derived type list. */
+
+static void
+gfc_free_dt_list (void)
+{
+ gfc_dt_list *dt, *n;
+
+ for (dt = gfc_derived_types; dt; dt = n)
+ {
+ n = dt->next;
+ gfc_free (dt);
+ }
+
+ gfc_derived_types = NULL;
+}
+
+
+/* Free the gfc_equiv_info's. */
+
+static void
+gfc_free_equiv_infos (gfc_equiv_info *s)
+{
+ if (s == NULL)
+ return;
+ gfc_free_equiv_infos (s->next);
+ gfc_free (s);
+}
+
+
+/* Free the gfc_equiv_lists. */
+
+static void
+gfc_free_equiv_lists (gfc_equiv_list *l)
+{
+ if (l == NULL)
+ return;
+ gfc_free_equiv_lists (l->next);
+ gfc_free_equiv_infos (l->equiv);
+ gfc_free (l);
+}
+
+
/* 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. */
void
-gfc_free_namespace (gfc_namespace * ns)
+gfc_free_namespace (gfc_namespace *ns)
{
gfc_charlen *cl, *cl2;
gfc_namespace *p, *q;
free_st_labels (ns->st_labels);
gfc_free_equiv (ns->equiv);
+ gfc_free_equiv_lists (ns->equiv_lists);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->operator[i]);
{
q = p;
p = p->sibling;
-
gfc_free_namespace (q);
}
}
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = NULL;
+ gfc_free_dt_list ();
}
/* 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);
gfc_gsymbol *
gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
{
- gfc_gsymbol *s;
+ int c;
if (symbol == NULL)
return NULL;
- if (strcmp (symbol->name, name) == 0)
- return symbol;
- s = gfc_find_gsymbol (symbol->left, name);
- if (s != NULL)
- return s;
+ while (symbol)
+ {
+ c = strcmp (name, symbol->name);
+ if (!c)
+ return symbol;
- s = gfc_find_gsymbol (symbol->right, name);
- if (s != NULL)
- return s;
+ symbol = (c < 0) ? symbol->left : symbol->right;
+ }
return NULL;
}
/* 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 overriden
+ 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;
+}
+