/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2014 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
#include "parse.h"
gfc_gsymbol *gfc_gsym_root = NULL;
-static gfc_symbol *changed_syms = NULL;
-
gfc_dt_list *gfc_derived_types;
-
-/* List of tentative typebound-procedures. */
-
-typedef struct tentative_tbp
-{
- gfc_typebound_proc *proc;
- struct tentative_tbp *next;
-}
-tentative_tbp;
-
-static tentative_tbp *tentative_tbp_list = NULL;
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
+static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
/* Handle a correctly parsed IMPLICIT NONE. */
void
-gfc_set_implicit_none (void)
+gfc_set_implicit_none (bool type, bool external, locus *loc)
{
int i;
- if (gfc_current_ns->seen_implicit_none)
- {
- gfc_error ("Duplicate IMPLICIT NONE statement at %C");
- return;
- }
-
- gfc_current_ns->seen_implicit_none = 1;
+ if (external)
+ gfc_current_ns->has_implicit_none_export = 1;
- for (i = 0; i < GFC_LETTERS; i++)
+ if (type)
{
- gfc_clear_ts (&gfc_current_ns->default_type[i]);
- gfc_current_ns->set_flag[i] = 1;
+ gfc_current_ns->seen_implicit_none = 1;
+ for (i = 0; i < GFC_LETTERS; i++)
+ {
+ if (gfc_current_ns->set_flag[i])
+ {
+ gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
+ "IMPLICIT statement", loc);
+ return;
+ }
+ gfc_clear_ts (&gfc_current_ns->default_type[i]);
+ gfc_current_ns->set_flag[i] = 1;
+ }
}
}
/* Prepare for a new implicit range. Sets flags in new_flag[]. */
-gfc_try
+bool
gfc_add_new_implicit_range (int c1, int c2)
{
int i;
{
gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
i + 'A');
- return FAILURE;
+ return false;
}
new_flag[i] = 1;
}
- return SUCCESS;
+ return true;
}
/* Add a matched implicit range for gfc_set_implicit(). Check if merging
the new implicit types back into the existing types will work. */
-gfc_try
+bool
gfc_merge_new_implicit (gfc_typespec *ts)
{
int i;
if (gfc_current_ns->seen_implicit_none)
{
gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
- return FAILURE;
+ return false;
}
for (i = 0; i < GFC_LETTERS; i++)
{
gfc_error ("Letter %c already has an IMPLICIT type at %C",
i + 'A');
- return FAILURE;
+ return false;
}
gfc_current_ns->default_type[i] = *ts;
gfc_current_ns->set_flag[i] = 1;
}
}
- return SUCCESS;
+ return true;
}
letter of its name. Fails if the letter in question has no default
type. */
-gfc_try
+bool
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
gfc_typespec *ts;
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
- return FAILURE;
+ return false;
}
sym->ts = *ts;
if (ts->type == BT_CHARACTER && ts->u.cl)
sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
+ else if (ts->type == BT_CLASS
+ && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+ return false;
- if (sym->attr.is_bind_c == 1)
+ if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
{
/* BIND(C) variables should not be implicitly declared. */
gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
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)
+ && sym->ns->proc_name->attr.is_bind_c != 0
+ && gfc_option.warn_c_binding_type)
{
/* Dummy args to a BIND(C) routine may not be interoperable if
they are implicitly typed. */
}
}
- return SUCCESS;
+ return true;
}
if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
{
- if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
- == SUCCESS)
+ if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
{
if (proc->result != proc)
{
goto conflict_std;\
}
-static gfc_try
+static bool
check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+ *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
*asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
*contiguous = "CONTIGUOUS", *generic = "GENERIC";
static const char *threadprivate = "THREADPRIVATE";
+ static const char *omp_declare_target = "OMP DECLARE TARGET";
const char *a1, *a2;
int standard;
gfc_error
("%s attribute not allowed in BLOCK DATA program unit at %L",
a1, where);
- return FAILURE;
+ return false;
}
}
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
-
+ case FL_NAMELIST:
+ gfc_error ("Namelist group name at %L cannot have the "
+ "SAVE attribute", where);
+ return false;
+ break;
case FL_PROCEDURE:
/* Conflicts between SAVE and PROCEDURE will be checked at
resolution stage, see "resolve_fl_procedure". */
case FL_VARIABLE:
- case FL_NAMELIST:
default:
break;
}
conf (dummy, entry);
conf (dummy, intrinsic);
conf (dummy, threadprivate);
+ conf (dummy, omp_declare_target);
conf (pointer, target);
conf (pointer, intrinsic);
conf (pointer, elemental);
+ conf (pointer, codimension);
conf (allocatable, elemental);
conf (target, external);
if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
conf (external, subroutine);
- if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: Procedure pointer at %C") == FAILURE)
- return FAILURE;
+ if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
+ "Procedure pointer at %C"))
+ return false;
conf (allocatable, pointer);
conf_std (allocatable, dummy, GFC_STD_F2003);
conf (in_equivalence, entry);
conf (in_equivalence, allocatable);
conf (in_equivalence, threadprivate);
+ conf (in_equivalence, omp_declare_target);
conf (dummy, result);
conf (entry, result);
conf (cray_pointer, entry);
conf (cray_pointee, allocatable);
- conf (cray_pointer, contiguous);
- conf (cray_pointer, codimension);
+ conf (cray_pointee, contiguous);
+ conf (cray_pointee, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
conf (cray_pointee, dummy);
conf (cray_pointee, in_common);
conf (cray_pointee, in_equivalence);
conf (cray_pointee, threadprivate);
+ conf (cray_pointee, omp_declare_target);
conf (data, dummy);
conf (data, function);
conf (procedure, asynchronous)
conf (procedure, entry)
+ conf (proc_pointer, abstract)
+
+ conf (entry, omp_declare_target)
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+ conf2 (omp_declare_target);
if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
{
a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
name, where);
- return FAILURE;
+ return false;
}
if (attr->is_bind_c)
{
gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
- return FAILURE;
+ return false;
}
break;
{
case PROC_ST_FUNCTION:
conf2 (dummy);
+ conf2 (target);
break;
case PROC_MODULE:
conf2 (subroutine);
conf2 (threadprivate);
conf2 (result);
+ conf2 (omp_declare_target);
if (attr->intent != INTENT_UNKNOWN)
{
conf2 (asynchronous);
conf2 (threadprivate);
conf2 (value);
- conf2 (is_bind_c);
conf2 (codimension);
conf2 (result);
+ if (!attr->is_iso_c)
+ conf2 (is_bind_c);
break;
default:
break;
}
- return SUCCESS;
+ return true;
conflict:
if (name == NULL)
gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
a1, a2, name, where);
- return FAILURE;
+ return false;
conflict_std:
if (name == NULL)
{
- return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ return gfc_notify_std (standard, "%s attribute "
"with %s attribute at %L", a1, a2,
where);
}
else
{
- return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ return gfc_notify_std (standard, "%s attribute "
"with %s attribute in '%s' at %L",
a1, a2, name, where);
}
}
-gfc_try
+bool
gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
locus *where ATTRIBUTE_UNUSED)
{
attr->ext_attr |= 1 << ext_attr;
- return SUCCESS;
+ return true;
}
/* Called from decl.c (attr_decl1) to check attributes, when declared
separately. */
-gfc_try
+bool
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
return check_conflict (attr, NULL, where);
}
-gfc_try
+bool
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->allocatable)
{
duplicate_attr ("ALLOCATABLE", where);
- return FAILURE;
+ return false;
}
if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
- && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ && !gfc_find_state (COMP_INTERFACE))
{
gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
where);
- return FAILURE;
+ return false;
}
attr->allocatable = 1;
}
-gfc_try
+bool
gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->codimension)
{
duplicate_attr ("CODIMENSION", where);
- return FAILURE;
+ return false;
}
if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
- && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ && !gfc_find_state (COMP_INTERFACE))
{
gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
"at %L", name, where);
- return FAILURE;
+ return false;
}
attr->codimension = 1;
}
-gfc_try
+bool
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->dimension)
{
duplicate_attr ("DIMENSION", where);
- return FAILURE;
+ return false;
}
if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
- && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ && !gfc_find_state (COMP_INTERFACE))
{
gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
"at %L", name, where);
- return FAILURE;
+ return false;
}
attr->dimension = 1;
}
-gfc_try
+bool
gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
attr->contiguous = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_external (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->external)
{
duplicate_attr ("EXTERNAL", where);
- return FAILURE;
+ return false;
}
if (attr->pointer && attr->if_source != IFSRC_IFBODY)
}
-gfc_try
+bool
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->intrinsic)
{
duplicate_attr ("INTRINSIC", where);
- return FAILURE;
+ return false;
}
attr->intrinsic = 1;
}
-gfc_try
+bool
gfc_add_optional (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->optional)
{
duplicate_attr ("OPTIONAL", where);
- return FAILURE;
+ return false;
}
attr->optional = 1;
}
-gfc_try
+bool
gfc_add_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
- && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ && !gfc_find_state (COMP_INTERFACE)))
{
duplicate_attr ("POINTER", where);
- return FAILURE;
+ return false;
}
if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
|| (attr->if_source == IFSRC_IFBODY
- && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ && !gfc_find_state (COMP_INTERFACE)))
attr->proc_pointer = 1;
else
attr->pointer = 1;
}
-gfc_try
+bool
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
attr->cray_pointer = 1;
return check_conflict (attr, NULL, where);
}
-gfc_try
+bool
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->cray_pointee)
{
gfc_error ("Cray Pointee at %L appears in multiple pointer()"
" statements", where);
- return FAILURE;
+ return false;
}
attr->cray_pointee = 1;
}
-gfc_try
+bool
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->is_protected)
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Duplicate PROTECTED attribute specified at %L",
- where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate PROTECTED attribute specified at %L",
+ where))
+ return false;
}
attr->is_protected = 1;
}
-gfc_try
+bool
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
attr->result = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (s == SAVE_EXPLICIT && gfc_pure (NULL))
{
gfc_error
("SAVE attribute at %L cannot be specified in a PURE procedure",
where);
- return FAILURE;
+ return false;
}
- if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ if (s == SAVE_EXPLICIT)
+ gfc_unset_implicit_pure (NULL);
if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Duplicate SAVE attribute specified at %L",
- where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate SAVE attribute specified at %L",
+ where))
+ return false;
}
attr->save = s;
}
-gfc_try
+bool
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->value)
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Duplicate VALUE attribute specified at %L",
- where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VALUE attribute specified at %L",
+ where))
+ return false;
}
attr->value = 1;
}
-gfc_try
+bool
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
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;
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VOLATILE attribute specified at %L",
+ where))
+ return false;
attr->volatile_ = 1;
attr->volatile_ns = gfc_current_ns;
}
-gfc_try
+bool
gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
given a ASYNCHRONOUS attribute. */
if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Duplicate ASYNCHRONOUS attribute specified at %L",
- where) == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate ASYNCHRONOUS attribute specified at %L",
+ where))
+ return false;
attr->asynchronous = 1;
attr->asynchronous_ns = gfc_current_ns;
}
-gfc_try
+bool
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->threadprivate)
{
duplicate_attr ("THREADPRIVATE", where);
- return FAILURE;
+ return false;
}
attr->threadprivate = 1;
}
-gfc_try
+bool
+gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->omp_declare_target)
+ return true;
+
+ attr->omp_declare_target = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+bool
gfc_add_target (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->target)
{
duplicate_attr ("TARGET", where);
- return FAILURE;
+ return false;
}
attr->target = 1;
}
-gfc_try
+bool
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
/* Duplicate dummy arguments are allowed due to ENTRY statements. */
attr->dummy = 1;
}
-gfc_try
+bool
gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
/* Duplicate attribute already checked for. */
attr->in_common = 1;
}
-gfc_try
+bool
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
/* Duplicate attribute already checked for. */
attr->in_equivalence = 1;
- if (check_conflict (attr, name, where) == FAILURE)
- return FAILURE;
+ if (!check_conflict (attr, name, where))
+ return false;
if (attr->flavor == FL_VARIABLE)
- return SUCCESS;
+ return true;
return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}
-gfc_try
+bool
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
attr->data = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
}
-gfc_try
+bool
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
attr->sequence = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_elemental (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->elemental)
{
duplicate_attr ("ELEMENTAL", where);
- return FAILURE;
+ return false;
}
attr->elemental = 1;
}
-gfc_try
+bool
gfc_add_pure (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->pure)
{
duplicate_attr ("PURE", where);
- return FAILURE;
+ return false;
}
attr->pure = 1;
}
-gfc_try
+bool
gfc_add_recursive (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->recursive)
{
duplicate_attr ("RECURSIVE", where);
- return FAILURE;
+ return false;
}
attr->recursive = 1;
}
-gfc_try
+bool
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->entry)
{
duplicate_attr ("ENTRY", where);
- return FAILURE;
+ return false;
}
attr->entry = 1;
}
-gfc_try
+bool
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
- && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
- return FAILURE;
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
attr->function = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
- && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
- return FAILURE;
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
attr->subroutine = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->flavor != FL_PROCEDURE
- && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
- return FAILURE;
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
attr->generic = 1;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->flavor != FL_PROCEDURE
- && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
- return FAILURE;
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
if (attr->procedure)
{
duplicate_attr ("PROCEDURE", where);
- return FAILURE;
+ return false;
}
attr->procedure = 1;
}
-gfc_try
+bool
gfc_add_abstract (symbol_attribute* attr, locus* where)
{
if (attr->abstract)
{
duplicate_attr ("ABSTRACT", where);
- return FAILURE;
+ return false;
}
attr->abstract = 1;
- return SUCCESS;
+
+ return check_conflict (attr, NULL, where);
}
/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
-gfc_try
+bool
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
|| f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
|| f == FL_NAMELIST) && check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->flavor == f && f == FL_VARIABLE)
- return SUCCESS;
+ return true;
if (attr->flavor != FL_UNKNOWN)
{
gfc_code2string (flavors, attr->flavor),
gfc_code2string (flavors, f), where);
- return FAILURE;
+ return false;
}
attr->flavor = f;
}
-gfc_try
+bool
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
const char *name, locus *where)
{
if (check_used (attr, name, where))
- return FAILURE;
+ return false;
if (attr->flavor != FL_PROCEDURE
- && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
- return FAILURE;
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
if (where == NULL)
where = &gfc_current_locus;
gfc_code2string (procedures, t), where,
gfc_code2string (procedures, attr->proc));
- return FAILURE;
+ return false;
}
attr->proc = t;
/* Statement functions are always scalar and functions. */
if (t == PROC_ST_FUNCTION
- && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
+ && ((!attr->function && !gfc_add_function (attr, name, where))
|| attr->dimension))
- return FAILURE;
+ return false;
return check_conflict (attr, name, where);
}
-gfc_try
+bool
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
if (check_used (attr, NULL, where))
- return FAILURE;
+ return false;
if (attr->intent == INTENT_UNKNOWN)
{
gfc_intent_string (attr->intent),
gfc_intent_string (intent), where);
- return FAILURE;
+ return false;
}
/* No checks for use-association in public and private statements. */
-gfc_try
+bool
gfc_add_access (symbol_attribute *attr, gfc_access access,
const char *name, locus *where)
{
where = &gfc_current_locus;
gfc_error ("ACCESS specification at %L was already specified", where);
- return FAILURE;
+ return false;
}
/* Set the is_bind_c field for the given symbol_attribute. */
-gfc_try
+bool
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
int is_proc_lang_bind_spec)
{
if (where == NULL)
where = &gfc_current_locus;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
+ return false;
return check_conflict (attr, name, where);
}
/* Set the extension field for the given symbol_attribute. */
-gfc_try
+bool
gfc_add_extension (symbol_attribute *attr, locus *where)
{
if (where == NULL)
else
attr->extension = 1;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
+ return false;
- return SUCCESS;
+ return true;
}
-gfc_try
+bool
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
gfc_formal_arglist * formal, locus *where)
{
if (check_used (&sym->attr, sym->name, where))
- return FAILURE;
+ return false;
if (where == NULL)
where = &gfc_current_locus;
{
gfc_error ("Symbol '%s' at %L already has an explicit interface",
sym->name, where);
- return FAILURE;
+ return false;
}
if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
{
gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
"body", sym->name, where);
- return FAILURE;
+ return false;
}
sym->formal = formal;
sym->attr.if_source = source;
- return SUCCESS;
+ return true;
}
/* Add a type to a symbol. */
-gfc_try
+bool
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
else
gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
where, gfc_basic_typename (type));
- return FAILURE;
+ return false;
}
if (sym->attr.procedure && sym->ts.interface)
{
gfc_error ("Procedure '%s' at %L may not have basic type of %s",
sym->name, where, gfc_basic_typename (ts->type));
- return FAILURE;
+ return false;
}
flavor = sym->attr.flavor;
|| flavor == FL_DERIVED || flavor == FL_NAMELIST)
{
gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
- return FAILURE;
+ return false;
}
sym->ts = *ts;
- return SUCCESS;
+ return true;
}
/* Check for missing attributes in the new symbol. Currently does
nothing, but it's not clear that it is unnecessary yet. */
-gfc_try
+bool
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
locus *where ATTRIBUTE_UNUSED)
{
- return SUCCESS;
+ return true;
}
attributes have a lot of side-effects but cannot be present given
where we are called from, so we ignore some bits. */
-gfc_try
+bool
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
int is_proc_lang_bind_spec;
them; cf. also PR 41034. */
dest->ext_attr |= src->ext_attr;
- if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
+ if (src->allocatable && !gfc_add_allocatable (dest, where))
goto fail;
- if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
+ if (src->dimension && !gfc_add_dimension (dest, NULL, where))
goto fail;
- if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
+ if (src->codimension && !gfc_add_codimension (dest, NULL, where))
goto fail;
- if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
+ if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
goto fail;
- if (src->optional && gfc_add_optional (dest, where) == FAILURE)
+ if (src->optional && !gfc_add_optional (dest, where))
goto fail;
- if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
+ if (src->pointer && !gfc_add_pointer (dest, where))
goto fail;
- if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+ if (src->is_protected && !gfc_add_protected (dest, NULL, where))
goto fail;
- if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
+ if (src->save && !gfc_add_save (dest, src->save, NULL, where))
goto fail;
- if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+ if (src->value && !gfc_add_value (dest, NULL, where))
goto fail;
- if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
+ if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
goto fail;
- if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
+ if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
goto fail;
if (src->threadprivate
- && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
+ && !gfc_add_threadprivate (dest, NULL, where))
goto fail;
- if (src->target && gfc_add_target (dest, where) == FAILURE)
+ if (src->omp_declare_target
+ && !gfc_add_omp_declare_target (dest, NULL, where))
goto fail;
- if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
+ if (src->target && !gfc_add_target (dest, where))
goto fail;
- if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
+ if (src->dummy && !gfc_add_dummy (dest, NULL, where))
+ goto fail;
+ if (src->result && !gfc_add_result (dest, NULL, where))
goto fail;
if (src->entry)
dest->entry = 1;
- if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
+ if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
goto fail;
- if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
+ if (src->in_common && !gfc_add_in_common (dest, NULL, where))
goto fail;
- if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
+ if (src->generic && !gfc_add_generic (dest, NULL, where))
goto fail;
- if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
+ if (src->function && !gfc_add_function (dest, NULL, where))
goto fail;
- if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
+ if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
goto fail;
- if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
+ if (src->sequence && !gfc_add_sequence (dest, NULL, where))
goto fail;
- if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
+ if (src->elemental && !gfc_add_elemental (dest, where))
goto fail;
- if (src->pure && gfc_add_pure (dest, where) == FAILURE)
+ if (src->pure && !gfc_add_pure (dest, where))
goto fail;
- if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
+ if (src->recursive && !gfc_add_recursive (dest, where))
goto fail;
if (src->flavor != FL_UNKNOWN
- && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
+ && !gfc_add_flavor (dest, src->flavor, NULL, where))
goto fail;
if (src->intent != INTENT_UNKNOWN
- && gfc_add_intent (dest, src->intent, where) == FAILURE)
+ && !gfc_add_intent (dest, src->intent, where))
goto fail;
if (src->access != ACCESS_UNKNOWN
- && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
+ && !gfc_add_access (dest, src->access, NULL, where))
goto fail;
- if (gfc_missing_attr (dest, where) == FAILURE)
+ if (!gfc_missing_attr (dest, where))
goto fail;
- if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
+ if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
goto fail;
- if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
+ if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
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;
+ && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
+ return false;
if (src->is_c_interop)
dest->is_c_interop = 1;
if (src->is_iso_c)
dest->is_iso_c = 1;
- if (src->external && gfc_add_external (dest, where) == FAILURE)
+ if (src->external && !gfc_add_external (dest, where))
goto fail;
- if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
+ if (src->intrinsic && !gfc_add_intrinsic (dest, where))
goto fail;
if (src->proc_pointer)
dest->proc_pointer = 1;
- return SUCCESS;
+ return true;
fail:
- return FAILURE;
+ return false;
}
already present. On success, the component pointer is modified to
point to the additional component structure. */
-gfc_try
+bool
gfc_add_component (gfc_symbol *sym, const char *name,
gfc_component **component)
{
{
gfc_error ("Component '%s' at %C already declared at %L",
name, &p->loc);
- return FAILURE;
+ return false;
}
tail = p;
{
gfc_error ("Component '%s' at %C already in the parent type "
"at %L", name, &sym->components->ts.u.derived->declared_at);
- return FAILURE;
+ return false;
}
/* Allocate a new component. */
p->ts.type = BT_UNKNOWN;
*component = p;
- return SUCCESS;
+ return true;
}
if (!sym)
return NULL;
+ if (sym->attr.unlimited_polymorphic)
+ return sym;
+
+ if (sym->attr.generic)
+ sym = gfc_find_dt_in_generic (sym);
+
if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
if (strcmp (p->name, name) == 0)
break;
+ if (p && sym->attr.use_assoc && !noaccess)
+ {
+ bool is_parent_comp = sym->attr.extension && (p == sym->components);
+ if (p->attr.access == ACCESS_PRIVATE ||
+ (p->attr.access != ACCESS_PUBLIC
+ && sym->component_access == ACCESS_PRIVATE
+ && !is_parent_comp))
+ {
+ if (!silent)
+ gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
+ name, sym->name);
+ return NULL;
+ }
+ }
+
if (p == NULL
&& sym->attr.extension
&& sym->components->ts.type == BT_DERIVED)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else if (sym->attr.use_assoc && !noaccess)
- {
- bool is_parent_comp = sym->attr.extension && (p == sym->components);
- if (p->attr.access == ACCESS_PRIVATE ||
- (p->attr.access != ACCESS_PUBLIC
- && sym->component_access == ACCESS_PRIVATE
- && !is_parent_comp))
- {
- if (!silent)
- gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
- name, sym->name);
- return NULL;
- }
- }
-
return p;
}
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
-
- gfc_free_formal_arglist (p->formal);
- gfc_free_namespace (p->formal_ns);
+ free (p->tb);
free (p);
}
switch (type)
{
case ST_LABEL_FORMAT:
- if (lp->referenced == ST_LABEL_TARGET)
+ if (lp->referenced == ST_LABEL_TARGET
+ || lp->referenced == ST_LABEL_DO_TARGET)
gfc_error ("Label %d at %C already referenced as branch target",
labelno);
else
break;
case ST_LABEL_TARGET:
+ case ST_LABEL_DO_TARGET:
if (lp->referenced == ST_LABEL_FORMAT)
gfc_error ("Label %d at %C already referenced as a format label",
labelno);
else
- lp->defined = ST_LABEL_TARGET;
+ lp->defined = type;
+ if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
+ && !gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
+ "which is not END DO or CONTINUE with "
+ "label %d at %C", labelno))
+ return;
break;
default:
/* Reference a label. Given a label and its type, see if that
reference is consistent with what is known about that label,
- updating the unknown state. Returns FAILURE if something goes
+ updating the unknown state. Returns false if something goes
wrong. */
-gfc_try
+bool
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
gfc_sl_type label_type;
int labelno;
- gfc_try rc;
+ bool rc;
if (lp == NULL)
- return SUCCESS;
+ return true;
labelno = lp->value;
lp->where = gfc_current_locus;
}
- if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
+ if (label_type == ST_LABEL_FORMAT
+ && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
{
gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
- rc = FAILURE;
+ rc = false;
goto done;
}
- if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
+ if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
+ || label_type == ST_LABEL_BAD_TARGET)
&& type == ST_LABEL_FORMAT)
{
gfc_error ("Label %d at %C previously used as branch target", labelno);
- rc = FAILURE;
+ rc = false;
goto done;
}
- lp->referenced = type;
- rc = SUCCESS;
+ if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && !gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
+ "at %C", labelno))
+ return false;
+
+ if (lp->referenced != ST_LABEL_DO_TARGET)
+ lp->referenced = type;
+ rc = true;
done:
return rc;
undo changes made to a symbol table if the current interpretation
of a statement is found to be incorrect. Whenever a symbol is
looked up, we make a copy of it and link to it. All of these
- symbols are kept in a singly linked list so that we can commit or
+ symbols are kept in a vector so that we can commit or
undo the changes at a later time.
A symtree may point to a symbol node outside of its namespace. In
}
}
+ if (parent_types && ns->parent != NULL)
+ ns->has_implicit_none_export = ns->parent->has_implicit_none_export;
+
ns->refs = 1;
return ns;
{
gfc_user_op *uop;
gfc_symtree *st;
+ gfc_namespace *ns = gfc_current_ns;
- st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+ if (ns->omp_udr_ns)
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->uop_root, name);
if (st != NULL)
return st->n.uop;
- st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
+ st = gfc_new_symtree (&ns->uop_root, name);
uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
- uop->ns = gfc_current_ns;
+ uop->ns = ns;
return uop;
}
gfc_free_namelist (sym->namelist);
- gfc_free_namespace (sym->formal_ns);
+ if (sym->ns != sym->formal_ns)
+ gfc_free_namespace (sym->formal_ns);
if (!sym->attr.generic_copy)
gfc_free_interface (sym->generic);
gfc_free_namespace (sym->f2k_derived);
+ if (sym->common_block && sym->common_block->name[0] != '\0')
+ {
+ sym->common_block->refs--;
+ if (sym->common_block->refs == 0)
+ free (sym->common_block);
+ }
+
free (sym);
}
if (sym == NULL)
return;
- if (sym->formal_ns != NULL && sym->refs == 2)
+ if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
+ && (!sym->attr.entry || !sym->module))
{
/* As formal_ns contains a reference to sym, delete formal_ns just
before the deletion of sym. */
/* 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;
if (!parent_flag)
break;
+ /* Don't escape an interface block. */
+ if (ns && !ns->has_import_set
+ && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ break;
+
ns = ns->parent;
}
while (ns != NULL);
}
+/* Tells whether there is only one set of changes in the stack. */
+
+static bool
+single_undo_checkpoint_p (void)
+{
+ if (latest_undo_chgset == &default_undo_chgset_var)
+ {
+ gcc_assert (latest_undo_chgset->previous == NULL);
+ return true;
+ }
+ else
+ {
+ gcc_assert (latest_undo_chgset->previous != NULL);
+ return false;
+ }
+}
+
/* Save symbol with the information necessary to back it out. */
static void
save_symbol_data (gfc_symbol *sym)
{
+ gfc_symbol *s;
+ unsigned i;
- if (sym->gfc_new || sym->old_symbol != NULL)
+ if (!single_undo_checkpoint_p ())
+ {
+ /* If there is more than one change set, look for the symbol in the
+ current one. If it is found there, we can reuse it. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ if (s == sym)
+ {
+ gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
+ return;
+ }
+ }
+ else if (sym->gfc_new || sym->old_symbol != NULL)
return;
- sym->old_symbol = XCNEW (gfc_symbol);
- *(sym->old_symbol) = *sym;
+ s = XCNEW (gfc_symbol);
+ *s = *sym;
+ sym->old_symbol = s;
+ sym->gfc_new = 0;
- sym->tlink = changed_syms;
- changed_syms = sym;
+ latest_undo_chgset->syms.safe_push (sym);
}
/* Try to find the symbol in ns. */
st = gfc_find_symtree (ns->sym_root, name);
+ if (st == NULL && ns->omp_udr_ns)
+ {
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->sym_root, name);
+ }
+
if (st == NULL)
{
/* If not there, create a new symbol. */
/* Add to the list of tentative symbols. */
p->old_symbol = NULL;
- p->tlink = changed_syms;
p->mark = 1;
p->gfc_new = 1;
- changed_syms = p;
+ latest_undo_chgset->syms.safe_push (p);
st = gfc_new_symtree (&ns->sym_root, name);
st->n.sym = p;
return i;
}
- if (gfc_current_ns->parent != NULL)
- {
- i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
- if (i)
- return i;
+ i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
+ if (i)
+ return i;
- if (st != NULL)
- {
- *result = st;
- return 0;
- }
+ if (st != NULL)
+ {
+ *result = st;
+ return 0;
}
return gfc_get_sym_tree (name, gfc_current_ns, result, false);
return i;
}
-/* Undoes all the changes made to symbols in the current statement.
- This subroutine is made simpler due to the fact that attributes are
- never removed once added. */
-void
-gfc_undo_symbols (void)
+/* Search for the symtree belonging to a gfc_common_head; we cannot use
+ head->name as the common_root symtree's name might be mangled. */
+
+static gfc_symtree *
+find_common_symtree (gfc_symtree *st, gfc_common_head *head)
{
- gfc_symbol *p, *q, *old;
- tentative_tbp *tbp, *tbq;
- for (p = changed_syms; p; p = q)
- {
- q = p->tlink;
+ gfc_symtree *result;
- if (p->gfc_new)
- {
- /* Symbol was new. */
- if (p->attr.in_common && p->common_block && p->common_block->head)
- {
- /* If the symbol was added to any common block, it
- needs to be removed to stop the resolver looking
- for a (possibly) dead symbol. */
+ if (st == NULL)
+ return NULL;
- if (p->common_block->head == p)
- p->common_block->head = p->common_next;
- else
- {
- gfc_symbol *cparent, *csym;
+ if (st->n.common == head)
+ return st;
- cparent = p->common_block->head;
- csym = cparent->common_next;
+ result = find_common_symtree (st->left, head);
+ if (!result)
+ result = find_common_symtree (st->right, head);
- while (csym != p)
- {
- cparent = csym;
- csym = csym->common_next;
- }
+ return result;
+}
- gcc_assert(cparent->common_next == p);
- cparent->common_next = csym->common_next;
- }
- }
+/* Clear the given storage, and make it the current change set for registering
+ changed symbols. Its contents are freed after a call to
+ gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
+ it is up to the caller to free the storage itself. It is usually a local
+ variable, so there is nothing to do anyway. */
- gfc_delete_symtree (&p->ns->sym_root, p->name);
+void
+gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
+{
+ chg_syms.syms = vNULL;
+ chg_syms.tbps = vNULL;
+ chg_syms.previous = latest_undo_chgset;
+ latest_undo_chgset = &chg_syms;
+}
- gfc_release_symbol (p);
- continue;
- }
- /* Restore previous state of symbol. Just copy simple stuff. */
- p->mark = 0;
- old = p->old_symbol;
+/* Restore previous state of symbol. Just copy simple stuff. */
+
+static void
+restore_old_symbol (gfc_symbol *p)
+{
+ gfc_symbol *old;
- p->ts.type = old->ts.type;
- p->ts.kind = old->ts.kind;
+ p->mark = 0;
+ old = p->old_symbol;
- p->attr = old->attr;
+ p->ts.type = old->ts.type;
+ p->ts.kind = old->ts.kind;
- if (p->value != old->value)
- {
- gfc_free_expr (old->value);
- p->value = NULL;
- }
+ p->attr = old->attr;
- if (p->as != old->as)
- {
- if (p->as)
- gfc_free_array_spec (p->as);
- p->as = old->as;
- }
+ if (p->value != old->value)
+ {
+ gcc_checking_assert (old->value == NULL);
+ gfc_free_expr (p->value);
+ p->value = NULL;
+ }
- p->generic = old->generic;
- p->component_access = old->component_access;
+ if (p->as != old->as)
+ {
+ if (p->as)
+ gfc_free_array_spec (p->as);
+ p->as = old->as;
+ }
- if (p->namelist != NULL && old->namelist == NULL)
+ p->generic = old->generic;
+ p->component_access = old->component_access;
+
+ if (p->namelist != NULL && old->namelist == NULL)
+ {
+ gfc_free_namelist (p->namelist);
+ p->namelist = NULL;
+ }
+ else
+ {
+ if (p->namelist_tail != old->namelist_tail)
{
- gfc_free_namelist (p->namelist);
- p->namelist = NULL;
+ gfc_free_namelist (old->namelist_tail->next);
+ old->namelist_tail->next = NULL;
}
- else
+ }
+
+ p->namelist_tail = old->namelist_tail;
+
+ if (p->formal != old->formal)
+ {
+ gfc_free_formal_arglist (p->formal);
+ p->formal = old->formal;
+ }
+
+ p->old_symbol = old->old_symbol;
+ free (old);
+}
+
+
+/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
+ the structure itself. */
+
+static void
+free_undo_change_set_data (gfc_undo_change_set &cs)
+{
+ cs.syms.release ();
+ cs.tbps.release ();
+}
+
+
+/* Given a change set pointer, free its target's contents and update it with
+ the address of the previous change set. Note that only the contents are
+ freed, not the target itself (the contents' container). It is not a problem
+ as the latter will be a local variable usually. */
+
+static void
+pop_undo_change_set (gfc_undo_change_set *&cs)
+{
+ free_undo_change_set_data (*cs);
+ cs = cs->previous;
+}
+
+
+static void free_old_symbol (gfc_symbol *sym);
+
+
+/* Merges the current change set into the previous one. The changes themselves
+ are left untouched; only one checkpoint is forgotten. */
+
+void
+gfc_drop_last_undo_checkpoint (void)
+{
+ gfc_symbol *s, *t;
+ unsigned i, j;
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ {
+ /* No need to loop in this case. */
+ if (s->old_symbol == NULL)
+ continue;
+
+ /* Remove the duplicate symbols. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
+ if (t == s)
+ {
+ latest_undo_chgset->previous->syms.unordered_remove (j);
+
+ /* S->OLD_SYMBOL is the backup symbol for S as it was at the
+ last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
+ shall contain from now on the backup symbol for S as it was
+ at the checkpoint before. */
+ if (s->old_symbol->gfc_new)
+ {
+ gcc_assert (s->old_symbol->old_symbol == NULL);
+ s->gfc_new = s->old_symbol->gfc_new;
+ free_old_symbol (s);
+ }
+ else
+ restore_old_symbol (s->old_symbol);
+ break;
+ }
+ }
+
+ latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
+ latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+
+ pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Undoes all the changes made to symbols since the previous checkpoint.
+ This subroutine is made simpler due to the fact that attributes are
+ never removed once added. */
+
+void
+gfc_restore_last_undo_checkpoint (void)
+{
+ gfc_symbol *p;
+ unsigned i;
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ {
+ if (p->gfc_new)
{
- if (p->namelist_tail != old->namelist_tail)
+ /* Symbol was new. */
+ if (p->attr.in_common && p->common_block && p->common_block->head)
{
- gfc_free_namelist (old->namelist_tail);
- old->namelist_tail->next = NULL;
+ /* If the symbol was added to any common block, it
+ needs to be removed to stop the resolver looking
+ for a (possibly) dead symbol. */
+
+ if (p->common_block->head == p && !p->common_next)
+ {
+ gfc_symtree st, *st0;
+ st0 = find_common_symtree (p->ns->common_root,
+ p->common_block);
+ if (st0)
+ {
+ st.name = st0->name;
+ gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
+ free (st0);
+ }
+ }
+
+ if (p->common_block->head == p)
+ p->common_block->head = p->common_next;
+ else
+ {
+ gfc_symbol *cparent, *csym;
+
+ cparent = p->common_block->head;
+ csym = cparent->common_next;
+
+ while (csym != p)
+ {
+ cparent = csym;
+ csym = csym->common_next;
+ }
+
+ gcc_assert(cparent->common_next == p);
+
+ cparent->common_next = csym->common_next;
+ }
}
- }
- p->namelist_tail = old->namelist_tail;
+ /* The derived type is saved in the symtree with the first
+ letter capitalized; the all lower-case version to the
+ derived type contains its associated generic function. */
+ if (p->attr.flavor == FL_DERIVED)
+ gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) p->name[0]),
+ &p->name[1]));
+ else
+ gfc_delete_symtree (&p->ns->sym_root, p->name);
- if (p->formal != old->formal)
- {
- gfc_free_formal_arglist (p->formal);
- p->formal = old->formal;
+ gfc_release_symbol (p);
}
-
- free (p->old_symbol);
- p->old_symbol = NULL;
- p->tlink = NULL;
+ else
+ restore_old_symbol (p);
}
- changed_syms = NULL;
+ latest_undo_chgset->syms.truncate (0);
+ latest_undo_chgset->tbps.truncate (0);
- for (tbp = tentative_tbp_list; tbp; tbp = tbq)
- {
- tbq = tbp->next;
- /* Procedure is already marked `error' by default. */
- free (tbp);
- }
- tentative_tbp_list = NULL;
+ if (!single_undo_checkpoint_p ())
+ pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Makes sure that there is only one set of changes; in other words we haven't
+ forgotten to pair a call to gfc_new_checkpoint with a call to either
+ gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
+
+static void
+enforce_single_undo_checkpoint (void)
+{
+ gcc_checking_assert (single_undo_checkpoint_p ());
+}
+
+
+/* Undoes all the changes made to symbols in the current statement. */
+
+void
+gfc_undo_symbols (void)
+{
+ enforce_single_undo_checkpoint ();
+ gfc_restore_last_undo_checkpoint ();
}
void
gfc_commit_symbols (void)
{
- gfc_symbol *p, *q;
- tentative_tbp *tbp, *tbq;
+ gfc_symbol *p;
+ gfc_typebound_proc *tbp;
+ unsigned i;
- for (p = changed_syms; p; p = q)
+ enforce_single_undo_checkpoint ();
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
{
- q = p->tlink;
- p->tlink = NULL;
p->mark = 0;
p->gfc_new = 0;
free_old_symbol (p);
}
- changed_syms = NULL;
+ latest_undo_chgset->syms.truncate (0);
- for (tbp = tentative_tbp_list; tbp; tbp = tbq)
- {
- tbq = tbp->next;
- tbp->proc->error = 0;
- free (tbp);
- }
- tentative_tbp_list = NULL;
+ FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
+ tbp->error = 0;
+ latest_undo_chgset->tbps.truncate (0);
}
gfc_commit_symbol (gfc_symbol *sym)
{
gfc_symbol *p;
+ unsigned i;
- 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;
- }
- }
+ enforce_single_undo_checkpoint ();
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ if (p == sym)
+ {
+ latest_undo_chgset->syms.unordered_remove (i);
+ break;
+ }
- sym->tlink = NULL;
sym->mark = 0;
sym->gfc_new = 0;
}
+/* Recursive function that deletes an entire tree and all the common
+ head structures it points to. */
+
+static void
+free_omp_udr_tree (gfc_symtree * omp_udr_tree)
+{
+ if (omp_udr_tree == NULL)
+ return;
+
+ free_omp_udr_tree (omp_udr_tree->left);
+ free_omp_udr_tree (omp_udr_tree->right);
+
+ gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
+ free (omp_udr_tree);
+}
+
+
/* Recursive function that deletes an entire tree and all the user
operator nodes that it contains. */
/* Free the charlen list from cl to end (end is not freed).
Free the whole list if end is NULL. */
-void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
+void
+gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
{
gfc_charlen *cl2;
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ free_omp_udr_tree (ns->omp_udr_root);
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
+ gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
void
gfc_symbol_done_2 (void)
{
-
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = NULL;
gfc_free_dt_list ();
+
+ enforce_single_undo_checkpoint ();
+ free_undo_change_set_data (*latest_undo_chgset);
}
-/* Clear mark bits from symbol nodes associated with a symtree node. */
+/* Count how many nodes a symtree has. */
-static void
-clear_sym_mark (gfc_symtree *st)
+static unsigned
+count_st_nodes (const gfc_symtree *st)
{
+ unsigned nodes;
+ if (!st)
+ return 0;
- st->n.sym->mark = 0;
+ nodes = count_st_nodes (st->left);
+ nodes++;
+ nodes += count_st_nodes (st->right);
+
+ return nodes;
}
-/* Recursively traverse the symtree nodes. */
+/* Convert symtree tree into symtree vector. */
-void
-gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
+static unsigned
+fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
{
if (!st)
- return;
+ return node_cntr;
+
+ node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
+ st_vec[node_cntr++] = st;
+ node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
- gfc_traverse_symtree (st->left, func);
- (*func) (st);
- gfc_traverse_symtree (st->right, func);
+ return node_cntr;
}
-/* Recursive namespace traversal function. */
+/* Traverse namespace. As the functions might modify the symtree, we store the
+ symtree as a vector and operate on this vector. Note: We assume that
+ sym_func or st_func never deletes nodes from the symtree - only adding is
+ allowed. Additionally, newly added nodes are not traversed. */
static void
-traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
+do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
+ void (*sym_func) (gfc_symbol *))
{
+ gfc_symtree **st_vec;
+ unsigned nodes, i, node_cntr;
- if (st == NULL)
- return;
+ gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
+ nodes = count_st_nodes (st);
+ st_vec = XALLOCAVEC (gfc_symtree *, nodes);
+ node_cntr = 0;
+ fill_st_vector (st, st_vec, node_cntr);
+
+ if (sym_func)
+ {
+ /* Clear marks. */
+ for (i = 0; i < nodes; i++)
+ st_vec[i]->n.sym->mark = 0;
+ for (i = 0; i < nodes; i++)
+ if (!st_vec[i]->n.sym->mark)
+ {
+ (*sym_func) (st_vec[i]->n.sym);
+ st_vec[i]->n.sym->mark = 1;
+ }
+ }
+ else
+ for (i = 0; i < nodes; i++)
+ (*st_func) (st_vec[i]);
+}
- traverse_ns (st->left, func);
- if (st->n.sym->mark == 0)
- (*func) (st->n.sym);
- st->n.sym->mark = 1;
+/* Recursively traverse the symtree nodes. */
- traverse_ns (st->right, func);
+void
+gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
+{
+ do_traverse_symtree (st, st_func, 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 (*sym_func) (gfc_symbol *))
{
-
- gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
-
- traverse_ns (ns->sym_root, func);
+ do_traverse_symtree (ns->sym_root, NULL, sym_func);
}
void
gfc_enforce_clean_symbol_state(void)
{
- gcc_assert (changed_syms == NULL);
+ enforce_single_undo_checkpoint ();
+ gcc_assert (latest_undo_chgset->syms.is_empty ());
}
for such. If an error occurs, the errors are reported here, allowing for
multiple errors to be handled for a single derived type. */
-gfc_try
+bool
verify_bind_c_derived_type (gfc_symbol *derived_sym)
{
gfc_component *curr_comp = NULL;
- gfc_try is_c_interop = FAILURE;
- gfc_try retval = SUCCESS;
+ bool is_c_interop = false;
+ bool retval = true;
if (derived_sym == NULL)
gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
/* 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;
+ return true;
/* The derived type must have the BIND attribute to be interoperable
J3/04-007, Section 15.2.3. */
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;
+ retval = false;
}
curr_comp = derived_sym->components;
derived_sym->name, &(derived_sym->declared_at));
derived_sym->ts.is_c_interop = 1;
derived_sym->attr.is_bind_c = 1;
- return SUCCESS;
+ return true;
}
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),
derived_sym->name, &(derived_sym->declared_at));
- retval = FAILURE;
+ retval = false;
}
if (curr_comp->attr.proc_pointer != 0)
" of the BIND(C) derived type '%s' at %L", curr_comp->name,
&curr_comp->loc, derived_sym->name,
&derived_sym->declared_at);
- retval = FAILURE;
+ retval = false;
}
/* The components cannot be allocatable.
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),
derived_sym->name, &(derived_sym->declared_at));
- retval = FAILURE;
+ retval = false;
}
/* BIND(C) derived types must have interoperable components. */
else
{
/* Grab the typespec for the given component and test the kind. */
- is_c_interop = verify_c_interop (&(curr_comp->ts));
+ is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
- if (is_c_interop != SUCCESS)
+ if (!is_c_interop)
{
/* Report warning and continue since not fatal. The
draft does specify a constraint that requires all fields
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 (derived_sym->attr.is_bind_c == 1
+ && gfc_option.warn_c_binding_type)
/* If the derived type is bind(c), all fields must be
interop. */
gfc_warning ("Component '%s' in derived type '%s' at %L "
"derived type '%s' is BIND(C)",
curr_comp->name, derived_sym->name,
&(curr_comp->loc), derived_sym->name);
- else
+ else if (gfc_option.warn_c_binding_type)
/* 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_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;
+ retval = false;
}
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;
+ retval = false;
}
/* 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)
+ if (!retval)
derived_sym->ts.is_c_interop = 0;
return retval;
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
-static gfc_try
-gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
- const char *module_name)
+static bool
+gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
{
- gfc_symtree *tmp_symtree;
- gfc_symbol *tmp_sym;
gfc_constructor *c;
- 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);
- }
+ gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
+ dt_symtree->n.sym->attr.referenced = 1;
- /* 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->attr.is_bind_c = 1;
+ tmp_sym->ts.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.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
- else
- tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.u.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.u.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);
+ tmp_sym->ts.f90_type = BT_VOID;
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.u.derived = dt_symtree->n.sym;
/* 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.f90_type = BT_VOID;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
c = gfc_constructor_first (tmp_sym->value->value.constructor);
- c->expr = gfc_get_expr ();
- c->expr->expr_type = EXPR_NULL;
+ c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
c->expr->ts.is_iso_c = 1;
- /* 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;
+ return true;
}
}
-/* 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, false);
- 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.u.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);
-
- /* Validate changes. */
- gfc_commit_symbol (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, int proc)
-{
- 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, false);
- 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++;
- if (proc)
- param_sym->attr.proc_pointer = 1;
- else
- param_sym->attr.pointer = 1;
- param_sym->attr.dummy = 1;
- param_sym->attr.use_assoc = 1;
-
- /* 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);
-
- /* Validate changes. */
- gfc_commit_symbol (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__";
-
- if (shape_param_name != NULL)
- shape_param = shape_param_name;
-
- gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
- 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 ();
-
- param_sym->as->rank = 1;
- param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 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);
-
- /* Validate changes. */
- gfc_commit_symbol (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)
+add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
{
sym->formal = formal;
each arg is set according to the existing ones. This function is
used when creating procedure declaration variables from a procedure
declaration statement (see match_proc_decl()) to create the formal
- args based on the args of a given named interface. */
-
-void
-gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
-{
- gfc_formal_arglist *head = NULL;
- gfc_formal_arglist *tail = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- gfc_formal_arglist *curr_arg = NULL;
- gfc_formal_arglist *formal_prev = NULL;
- /* Save current namespace so we can change it for formal args. */
- gfc_namespace *parent_ns = gfc_current_ns;
-
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace (parent_ns, 0);
- gfc_current_ns->proc_name = dest;
-
- for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
- {
- formal_arg = gfc_get_formal_arglist ();
- gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
-
- /* May need to copy more info for the symbol. */
- formal_arg->sym->attr = curr_arg->sym->attr;
- formal_arg->sym->ts = curr_arg->sym->ts;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
-
- /* If this isn't the first arg, set up the next ptr. For the
- last arg built, the formal_arg->next will never get set to
- anything other than NULL. */
- if (formal_prev != NULL)
- formal_prev->next = formal_arg;
- else
- formal_arg->next = NULL;
-
- formal_prev = formal_arg;
-
- /* Add arg to list of formal args. */
- add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- add_proc_interface (dest, IFSRC_DECL, head);
-
- /* Store the formal namespace information. */
- if (dest->formal != NULL)
- /* The current ns should be that for the dest proc. */
- dest->formal_ns = gfc_current_ns;
- /* Restore the current namespace to what it was on entry. */
- gfc_current_ns = parent_ns;
-}
+ args based on the args of a given named interface.
+ When an actual argument list is provided, skip the absent arguments.
+ To be used together with gfc_se->ignore_optional. */
void
-gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
+ gfc_actual_arglist *actual)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
gfc_formal_arglist *formal_arg = NULL;
gfc_intrinsic_arg *curr_arg = NULL;
gfc_formal_arglist *formal_prev = NULL;
+ gfc_actual_arglist *act_arg = actual;
/* Save current namespace so we can change it for formal args. */
gfc_namespace *parent_ns = gfc_current_ns;
for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
{
+ /* Skip absent arguments. */
+ if (actual)
+ {
+ gcc_assert (act_arg != NULL);
+ if (act_arg->expr == NULL)
+ {
+ act_arg = act_arg->next;
+ continue;
+ }
+ act_arg = act_arg->next;
+ }
formal_arg = gfc_get_formal_arglist ();
gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
}
-void
-gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
-{
- gfc_formal_arglist *head = NULL;
- gfc_formal_arglist *tail = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- gfc_formal_arglist *curr_arg = NULL;
- gfc_formal_arglist *formal_prev = NULL;
- /* Save current namespace so we can change it for formal args. */
- gfc_namespace *parent_ns = gfc_current_ns;
-
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace (parent_ns, 0);
- /* TODO: gfc_current_ns->proc_name = dest;*/
-
- for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
- {
- formal_arg = gfc_get_formal_arglist ();
- gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
-
- /* May need to copy more info for the symbol. */
- formal_arg->sym->attr = curr_arg->sym->attr;
- formal_arg->sym->ts = curr_arg->sym->ts;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
-
- /* If this isn't the first arg, set up the next ptr. For the
- last arg built, the formal_arg->next will never get set to
- anything other than NULL. */
- if (formal_prev != NULL)
- formal_prev->next = formal_arg;
- else
- formal_arg->next = NULL;
-
- formal_prev = formal_arg;
-
- /* Add arg to list of formal args. */
- add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- gfc_free_formal_arglist (dest->formal);
- dest->formal = head;
- dest->attr.if_source = IFSRC_DECL;
-
- /* Store the formal namespace information. */
- if (dest->formal != NULL)
- /* The current ns should be that for the dest proc. */
- dest->formal_ns = gfc_current_ns;
- /* Restore the current namespace to what it was on entry. */
- gfc_current_ns = parent_ns;
-}
-
-
-/* Builds the parameter list for the iso_c_binding procedure
- c_f_pointer or c_f_procpointer. The old_sym typically refers to a
- 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_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", 1);
- }
- else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr", old_sym->intmod_sym_id);
- gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr", 0);
- /* If we're dealing with c_f_pointer, it has an optional third arg. */
- 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;
-}
-
static int
std_for_isocbinding_symbol (int id)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a:\
return d;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a:\
+ return d;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
default:
return GFC_STD_F2003;
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. */
-
+ end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
+ point to the symtree for c_(fun)ptr. */
-void
+gfc_symtree *
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
- const char *local_name)
+ const char *local_name, gfc_symtree *dt_symtree,
+ bool hidden)
{
- const char *const name = (local_name && local_name[0]) ? local_name
- : c_interop_kinds_table[s].name;
- gfc_symtree *tmp_symtree = NULL;
+ const char *const name = (local_name && local_name[0])
+ ? local_name : c_interop_kinds_table[s].name;
+ gfc_symtree *tmp_symtree;
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;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
- return;
+ return NULL;
+
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (hidden
+ && (!tmp_symtree || !tmp_symtree->n.sym
+ || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
+ || tmp_symtree->n.sym->intmod_sym_id != s))
+ tmp_symtree = NULL;
+
+ /* Already exists in this scope so don't re-add it. */
+ if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
+ && (!tmp_sym->attr.generic
+ || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
+ && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+ {
+ if (tmp_sym->attr.flavor == FL_DERIVED
+ && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+ {
+ gfc_dt_list *dt_list;
+ dt_list = gfc_get_dt_list ();
+ dt_list->derived = tmp_sym;
+ dt_list->next = gfc_derived_types;
+ gfc_derived_types = dt_list;
+ }
- /* 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;
+ return tmp_symtree;
+ }
/* Create the sym tree in the current ns. */
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
- if (tmp_symtree)
- tmp_sym = tmp_symtree->n.sym;
+ if (hidden)
+ {
+ tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+ tmp_sym = gfc_new_symbol (name, gfc_current_ns);
+
+ /* Add to the list of tentative symbols. */
+ latest_undo_chgset->syms.safe_push (tmp_sym);
+ tmp_sym->old_symbol = NULL;
+ tmp_sym->mark = 1;
+ tmp_sym->gfc_new = 1;
+
+ tmp_symtree->n.sym = tmp_sym;
+ tmp_sym->refs++;
+ }
else
- gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
- "create symbol");
+ {
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ gcc_assert (tmp_symtree);
+ tmp_sym = tmp_symtree->n.sym;
+ }
/* 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;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->attr.use_assoc = 1;
+
+ gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
+ || s == ISOCBINDING_NULL_PTR);
switch (s)
{
#define NAMED_INTCST(a,b,c,d) case a :
-#define NAMED_REALCST(a,b,c) case a :
-#define NAMED_CMPXCST(a,b,c) case a :
+#define NAMED_REALCST(a,b,c,d) case a :
+#define NAMED_CMPXCST(a,b,c,d) case a :
#define NAMED_LOGCST(a,b,c) case a :
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
/* 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;
/* 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:
+ {
+ gfc_symbol *dt_sym;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
- /* 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.u.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->attr.pointer = 0;
- tmp_comp->attr.dimension = 0;
+ /* Generate real derived type. */
+ if (hidden)
+ dt_sym = tmp_sym;
+ else
+ {
+ const char *hidden_name;
+ gfc_interface *intr, *head;
+
+ hidden_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char)
+ tmp_sym->name[0]),
+ &tmp_sym->name[1]);
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ hidden_name);
+ gcc_assert (tmp_symtree == NULL);
+ gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+ dt_sym = tmp_symtree->n.sym;
+ dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
+ ? "c_ptr" : "c_funptr");
+
+ /* Generate an artificial generic function. */
+ head = tmp_sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ tmp_sym->generic = intr;
+
+ if (!tmp_sym->attr.generic
+ && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
+ return NULL;
+
+ if (!tmp_sym->attr.function
+ && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
+ return NULL;
+ }
- /* Mark the component as C interoperable. */
- tmp_comp->ts.is_c_interop = 1;
+ /* Say what module this symbol belongs to. */
+ dt_sym->module = gfc_get_string (mod_name);
+ dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ dt_sym->intmod_sym_id = s;
+ dt_sym->attr.use_assoc = 1;
+
+ /* Initialize an integer constant expression node. */
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->ts.is_c_interop = 1;
+ dt_sym->attr.is_c_interop = 1;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->component_access = ACCESS_PRIVATE;
+ dt_sym->ts.is_iso_c = 1;
+ dt_sym->ts.type = BT_DERIVED;
+ dt_sym->ts.f90_type = BT_VOID;
+
+ /* 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. */
+ dt_sym->attr.is_bind_c = 1;
+
+ dt_sym->attr.referenced = 1;
+ dt_sym->ts.u.derived = dt_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 = dt_sym;
+ (*dt_list_ptr)->next = NULL;
+
+ gfc_add_component (dt_sym, "c_address", &tmp_comp);
+ if (tmp_comp == NULL)
+ gcc_unreachable ();
+
+ 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->attr.access = ACCESS_PRIVATE;
+
+ /* 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);
+ gen_special_c_interop_ptr (tmp_sym, dt_symtree);
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.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_PTR);
- else
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
-
- if (tmp_sym->ts.u.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.u.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.pure = 1;
- 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 ();
}
gfc_commit_symbol (tmp_sym);
-}
-
-
-/* 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);
- new_symtree->n.sym->from_intmod = old_sym->from_intmod;
- new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
- if (old_sym->attr.function)
- new_symtree->n.sym->result = new_symtree->n.sym;
- /* 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;
+ return tmp_symtree;
}
/* Check that a symbol is already typed. If strict is not set, an untyped
symbol is acceptable for non-standard-conforming mode. */
-gfc_try
+bool
gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
bool strict, locus where)
{
gcc_assert (sym);
if (gfc_matching_prefix)
- return SUCCESS;
+ return true;
/* Check for the type and try to give it an implicit one. */
if (sym->ts.type == BT_UNKNOWN
- && gfc_set_default_type (sym, 0, ns) == FAILURE)
+ && !gfc_set_default_type (sym, 0, ns))
{
if (strict)
{
gfc_error ("Symbol '%s' is used before it is typed at %L",
sym->name, &where);
- return FAILURE;
+ return false;
}
- if (gfc_notify_std (GFC_STD_GNU,
- "Extension: Symbol '%s' is used before"
- " it is typed at %L", sym->name, &where) == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_GNU, "Symbol '%s' is used before"
+ " it is typed at %L", sym->name, &where))
+ return false;
}
/* Everything is ok. */
- return SUCCESS;
+ return true;
}
gfc_get_typebound_proc (gfc_typebound_proc *tb0)
{
gfc_typebound_proc *result;
- tentative_tbp *list_node;
result = XCNEW (gfc_typebound_proc);
if (tb0)
*result = *tb0;
result->error = 1;
- list_node = XCNEW (tentative_tbp);
- list_node->next = tentative_tbp_list;
- list_node->proc = result;
- tentative_tbp_list = list_node;
+ latest_undo_chgset->tbps.safe_push (result);
return result;
}
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
+ gcc_assert (derived);
+
+ if (derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
+
if (!derived->attr.extension)
return NULL;
gcc_assert (derived->components->ts.type == BT_DERIVED);
gcc_assert (derived->components->ts.u.derived);
+ if (derived->components->ts.u.derived->attr.generic)
+ return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
return derived->components->ts.u.derived;
}
bool is_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->type == BT_DERIVED);
+ if (is_class1
+ && ts1->u.derived->components
+ && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ return 1;
+
if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
return (ts1->type == ts2->type);
if (is_derived1 && is_derived2)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+ if (is_derived1 && is_class2)
+ return gfc_compare_derived_types (ts1->u.derived,
+ ts2->u.derived->components->ts.u.derived);
if (is_class1 && is_derived2)
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
ts2->u.derived);
if (!sym->assoc)
return false;
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
if (!sym->assoc->variable)
return false;
return true;
}
+
+
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
+{
+ gfc_interface *intr = NULL;
+
+ if (!sym || sym->attr.flavor == FL_DERIVED)
+ return sym;
+
+ if (sym->attr.generic)
+ for (intr = sym->generic; intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+ return intr ? intr->sym : NULL;
+}
+
+
+/* Get the dummy arguments from a procedure symbol. If it has been declared
+ via a PROCEDURE statement with a named interface, ts.interface will be set
+ and the arguments need to be taken from there. */
+
+gfc_formal_arglist *
+gfc_sym_get_dummy_args (gfc_symbol *sym)
+{
+ gfc_formal_arglist *dummies;
+
+ dummies = sym->formal;
+ if (dummies == NULL && sym->ts.interface != NULL)
+ dummies = sym->ts.interface->formal;
+
+ return dummies;
+}
projects / platform / upstream / gcc.git / blobdiff