X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fsymbol.c;h=c86fa9ae40e957cd6e4ca9b674d7c4574ed22cfe;hp=0b5e8e727a44d5c713c8385df7df4e443a142e19;hb=f3db21c0d32a7df706d4da17d3dbbfae6f691538;hpb=2ef746b7aa6b477efd6358a950ffc6c880ab519e diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0b5e8e727a4..c86fa9ae40e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1,13 +1,13 @@ /* 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, 2008 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -16,16 +16,17 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +along with GCC; see the file COPYING3. If not see +. */ #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. */ @@ -77,6 +78,12 @@ const mstring ifsrc_types[] = 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. */ @@ -90,6 +97,8 @@ gfc_gsymbol *gfc_gsym_root = NULL; static gfc_symbol *changed_syms = NULL; +gfc_dt_list *gfc_derived_types; + /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ @@ -106,6 +115,14 @@ gfc_set_implicit_none (void) { 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; + for (i = 0; i < GFC_LETTERS; i++) { gfc_clear_ts (&gfc_current_ns->default_type[i]); @@ -156,10 +173,16 @@ gfc_add_new_implicit_range (int c1, int c2) 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; + if (gfc_current_ns->seen_implicit_none) + { + gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); + return FAILURE; + } + for (i = 0; i < GFC_LETTERS; i++) { if (new_flag[i]) @@ -182,11 +205,17 @@ gfc_merge_new_implicit (gfc_typespec * ts) /* 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"); @@ -202,7 +231,7 @@ gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns) 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; @@ -226,10 +255,72 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) 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 @@ -237,20 +328,35 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) #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"; + *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", + *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", + *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", + *volatile_ = "VOLATILE", *protected = "PROTECTED", + *is_bind_c = "BIND(C)", *procedure = "PROCEDURE"; + static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; + int standard; if (where == NULL) where = &gfc_current_locus; @@ -259,7 +365,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) { a1 = pointer; a2 = intent; - goto conflict; + standard = GFC_STD_F2003; + goto conflict_std; } /* Check for attributes not allowed in a BLOCK DATA. */ @@ -267,6 +374,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) { a1 = NULL; + if (attr->in_namelist) + a1 = in_namelist; if (attr->allocatable) a1 = allocatable; if (attr->external) @@ -283,32 +392,81 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) 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); + conf (entry, intrinsic); + + if ((attr->if_source && !attr->procedure) || 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 (dummy, result); + conf (in_equivalence, use_assoc); + conf (in_equivalence, dummy); + conf (in_equivalence, target); + conf (in_equivalence, pointer); + conf (in_equivalence, function); + conf (in_equivalence, result); + conf (in_equivalence, entry); + conf (in_equivalence, allocatable); + conf (in_equivalence, threadprivate); + conf (in_namelist, pointer); conf (in_namelist, allocatable); @@ -316,13 +474,102 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) 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); + conf (is_bind_c, elemental); + + /* Need to also get volatile attr, according to 5.1 of F2003 draft. + Parameter conflict caught below. Also, value cannot be specified + for a dummy procedure. */ + + /* Cray pointer/pointee conflicts. */ + conf (cray_pointer, cray_pointee); + conf (cray_pointer, dimension); + conf (cray_pointer, pointer); + conf (cray_pointer, target); + conf (cray_pointer, allocatable); + conf (cray_pointer, external); + conf (cray_pointer, intrinsic); + conf (cray_pointer, in_namelist); + conf (cray_pointer, function); + conf (cray_pointer, subroutine); + conf (cray_pointer, entry); + + conf (cray_pointee, allocatable); + conf (cray_pointee, intent); + conf (cray_pointee, optional); + conf (cray_pointee, dummy); + conf (cray_pointee, target); + conf (cray_pointee, intrinsic); + conf (cray_pointee, pointer); + 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; + } + + conf (procedure, allocatable) + conf (procedure, dimension) + conf (procedure, intrinsic) + conf (procedure, protected) + conf (procedure, target) + conf (procedure, value) + conf (procedure, volatile_) + conf (procedure, entry) + /* TODO: Implement procedure pointers. */ + if (attr->procedure && attr->pointer) + { + gfc_error ("Fortran 2003: Procedure pointers at %L are " + "not yet implemented in gfortran", where); + return FAILURE; + } + 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; } @@ -333,9 +580,11 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) 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); @@ -345,6 +594,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (optional); conf2 (function); conf2 (subroutine); + conf2 (threadprivate); break; case FL_VARIABLE: @@ -356,19 +606,21 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) 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_ST_FUNCTION: conf2 (in_common); + conf2 (dummy); break; case PROC_MODULE: @@ -378,7 +630,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) case PROC_DUMMY: conf2 (result); conf2 (in_common); - conf2 (save); + conf2 (threadprivate); break; default: @@ -389,7 +641,6 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) case FL_DERIVED: conf2 (dummy); - conf2 (save); conf2 (pointer); conf2 (target); conf2 (external); @@ -399,6 +650,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (entry); conf2 (function); conf2 (subroutine); + conf2 (threadprivate); if (attr->intent != INTENT_UNKNOWN) { @@ -416,9 +668,15 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (subroutine); conf2 (entry); conf2 (pointer); + conf2 (protected); conf2 (target); conf2 (dummy); conf2 (in_common); + conf2 (value); + conf2 (volatile_); + conf2 (threadprivate); + conf2 (value); + conf2 (is_bind_c); break; default: @@ -436,17 +694,33 @@ conflict: 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; @@ -464,7 +738,7 @@ gfc_set_sym_referenced (gfc_symbol * sym) 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) @@ -484,46 +758,37 @@ check_used (symbol_attribute * attr, const char * name, locus * where) } -/* 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) @@ -538,10 +803,10 @@ gfc_add_allocatable (symbol_attribute * attr, locus * where) try -gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where) +gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) { - if (check_used (attr, name, where) || check_done (attr, where)) + if (check_used (attr, name, where)) return FAILURE; if (attr->dimension) @@ -556,10 +821,10 @@ gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where) 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) @@ -575,10 +840,10 @@ gfc_add_external (symbol_attribute * attr, locus * where) 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) @@ -594,10 +859,10 @@ gfc_add_intrinsic (symbol_attribute * attr, locus * where) 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) @@ -612,10 +877,10 @@ gfc_add_optional (symbol_attribute * attr, locus * where) 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; @@ -624,10 +889,61 @@ gfc_add_pointer (symbol_attribute * attr, locus * where) try -gfc_add_result (symbol_attribute * attr, const char *name, locus * where) +gfc_add_cray_pointer (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return FAILURE; + + attr->cray_pointer = 1; + return check_conflict (attr, NULL, where); +} + + +try +gfc_add_cray_pointee (symbol_attribute *attr, locus *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); + return FAILURE; + } + + attr->cray_pointee = 1; + return check_conflict (attr, NULL, where); +} + + +try +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; @@ -636,7 +952,7 @@ gfc_add_result (symbol_attribute * attr, const char *name, locus * where) try -gfc_add_save (symbol_attribute * attr, const char *name, locus * where) +gfc_add_save (symbol_attribute *attr, const char *name, locus *where) { if (check_used (attr, name, where)) @@ -650,22 +966,83 @@ gfc_add_save (symbol_attribute * attr, const char *name, locus * where) return FAILURE; } - if (attr->save) + if (attr->save == SAVE_EXPLICIT) + { + if (gfc_notify_std (GFC_STD_LEGACY, + "Duplicate SAVE attribute specified at %L", + where) + == FAILURE) + return FAILURE; + } + + 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 ("SAVE", where); + duplicate_attr ("THREADPRIVATE", where); return FAILURE; } - attr->save = 1; + 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) @@ -680,7 +1057,7 @@ gfc_add_target (symbol_attribute * attr, locus * where) try -gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where) +gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) { if (check_used (attr, name, where)) @@ -693,10 +1070,10 @@ gfc_add_dummy (symbol_attribute * attr, const char *name, locus * 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. */ @@ -712,6 +1089,22 @@ gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where) try +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 (attr->flavor == FL_VARIABLE) + return SUCCESS; + + return gfc_add_flavor (attr, FL_VARIABLE, name, where); +} + + +try gfc_add_data (symbol_attribute *attr, const char *name, locus *where) { @@ -724,8 +1117,7 @@ gfc_add_data (symbol_attribute *attr, const char *name, locus *where) 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; @@ -734,7 +1126,7 @@ gfc_add_in_namelist (symbol_attribute * attr, const char *name, 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)) @@ -746,43 +1138,61 @@ gfc_add_sequence (symbol_attribute * attr, const char *name, locus * 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; + if (attr->elemental) + { + duplicate_attr ("ELEMENTAL", where); + return FAILURE; + } + attr->elemental = 1; return check_conflict (attr, NULL, where); } try -gfc_add_pure (symbol_attribute * attr, locus * where) +gfc_add_pure (symbol_attribute *attr, locus *where) { - if (check_used (attr, NULL, where) || check_done (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; + if (attr->pure) + { + duplicate_attr ("PURE", where); + return FAILURE; + } + attr->pure = 1; return check_conflict (attr, NULL, where); } try -gfc_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; + if (attr->recursive) + { + duplicate_attr ("RECURSIVE", where); + return FAILURE; + } + attr->recursive = 1; return check_conflict (attr, NULL, where); } try -gfc_add_entry (symbol_attribute * attr, const char *name, locus * where) +gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) { if (check_used (attr, name, where)) @@ -800,7 +1210,7 @@ gfc_add_entry (symbol_attribute * attr, const char *name, locus * 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 @@ -813,7 +1223,7 @@ gfc_add_function (symbol_attribute * attr, const char *name, locus * where) 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 @@ -826,7 +1236,7 @@ gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where) 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 @@ -838,12 +1248,35 @@ gfc_add_generic (symbol_attribute * attr, const char *name, locus * where) } +try +gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, NULL, where)) + return FAILURE; + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) + return FAILURE; + + if (attr->procedure) + { + duplicate_attr ("PROCEDURE", where); + return FAILURE; + } + + attr->procedure = 1; + + return check_conflict (attr, NULL, where); +} + + /* Flavors are special because some flavors are not what Fortran considers attributes and can be reaffirmed multiple times. */ 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 @@ -859,9 +1292,14 @@ gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name, 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; } @@ -873,11 +1311,11 @@ gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name, 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 @@ -889,9 +1327,8 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t, if (attr->proc != PROC_UNKNOWN) { - gfc_error ("%s procedure at %L is already %s %s procedure", + gfc_error ("%s procedure at %L is already declared as %s procedure", gfc_code2string (procedures, t), where, - gfc_article (gfc_code2string (procedures, attr->proc)), gfc_code2string (procedures, attr->proc)); return FAILURE; @@ -910,7 +1347,7 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t, 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)) @@ -936,8 +1373,8 @@ gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * 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) @@ -954,9 +1391,35 @@ gfc_add_access (symbol_attribute * attr, gfc_access access, } +/* 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)) @@ -983,29 +1446,34 @@ gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source, /* 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); @@ -1020,9 +1488,9 @@ gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * 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)); } @@ -1030,8 +1498,8 @@ gfc_clear_attr (symbol_attribute * attr) 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; @@ -1043,9 +1511,10 @@ gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED, 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; @@ -1055,8 +1524,17 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) 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) @@ -1103,13 +1581,26 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) if (gfc_missing_attr (dest, where) == FAILURE) goto fail; - /* 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->cray_pointer && gfc_add_cray_pointer (dest, 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; + + if (src->external && gfc_add_external (dest, where) == FAILURE) + goto fail; + if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE) + goto fail; return SUCCESS; @@ -1131,7 +1622,8 @@ fail: 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; @@ -1169,7 +1661,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen 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; @@ -1204,14 +1696,14 @@ switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) 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; - if (sym->components != NULL) + if (sym->components != NULL || sym->attr.zero_comp) return sym; /* Already defined. */ if (sym->ns->parent == NULL) @@ -1240,15 +1732,7 @@ gfc_use_derived (gfc_symbol * sym) 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); @@ -1270,7 +1754,7 @@ bad: 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; @@ -1291,7 +1775,8 @@ gfc_find_component (gfc_symbol * sym, const char *name) 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); @@ -1307,7 +1792,7 @@ gfc_find_component (gfc_symbol * sym, const char *name) they point to. */ static void -free_components (gfc_component * p) +free_components (gfc_component *p) { gfc_component *q; @@ -1323,15 +1808,16 @@ free_components (gfc_component * p) } -/* 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; } @@ -1339,53 +1825,67 @@ gfc_set_component_attr (gfc_component * c, symbol_attribute * attr) 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); } @@ -1398,11 +1898,17 @@ gfc_get_st_label (int labelno) 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)); @@ -1410,11 +1916,7 @@ gfc_get_st_label (int labelno) 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; } @@ -1426,7 +1928,7 @@ gfc_get_st_label (int labelno) 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; @@ -1473,7 +1975,7 @@ gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus) 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; @@ -1515,6 +2017,35 @@ done: } +/*******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 @@ -1538,7 +2069,7 @@ done: 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; @@ -1562,7 +2093,7 @@ gfc_get_namespace (gfc_namespace * parent, int parent_types) if (parent_types && ns->parent != NULL) { - /* Copy parent settings */ + /* Copy parent settings. */ *ts = ns->parent->default_type[i - 'a']; continue; } @@ -1594,7 +2125,7 @@ gfc_get_namespace (gfc_namespace * parent, int parent_types) /* Comparison function for symtree nodes. */ static int -compare_symtree (void * _st1, void * _st2) +compare_symtree (void *_st1, void *_st2) { gfc_symtree *st1, *st2; @@ -1608,7 +2139,7 @@ compare_symtree (void * _st1, void * _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; @@ -1622,8 +2153,8 @@ gfc_new_symtree (gfc_symtree ** root, const char *name) /* Delete a symbol from the tree. Does not free the symbol itself! */ -static void -delete_symtree (gfc_symtree ** root, const char *name) +void +gfc_delete_symtree (gfc_symtree **root, const char *name) { gfc_symtree st, *st0; @@ -1640,7 +2171,7 @@ delete_symtree (gfc_symtree ** root, const char *name) 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; @@ -1657,6 +2188,20 @@ gfc_find_symtree (gfc_symtree * st, const char *name) } +/* Return a symtree node with a name that is guaranteed to be unique + within the namespace and corresponds to an illegal fortran name. */ + +gfc_symtree * +gfc_get_unique_symtree (gfc_namespace *ns) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int serial = 0; + + sprintf (name, "@%d", serial++); + return gfc_new_symtree (&ns->sym_root, name); +} + + /* Given a name find a user operator node, creating it if it doesn't exist. These are much simpler than symbols because they can't be ambiguous with one another. */ @@ -1686,7 +2231,7 @@ gfc_get_uop (const char *name) 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; @@ -1701,7 +2246,7 @@ gfc_find_uop (const char *name, gfc_namespace * ns) /* 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) @@ -1717,7 +2262,8 @@ gfc_free_symbol (gfc_symbol * sym) 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); @@ -1728,7 +2274,7 @@ gfc_free_symbol (gfc_symbol * sym) /* 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; @@ -1744,6 +2290,16 @@ gfc_new_symbol (const char *name, gfc_namespace * ns) 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; } @@ -1751,7 +2307,7 @@ gfc_new_symbol (const char *name, gfc_namespace * ns) /* 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) @@ -1768,8 +2324,8 @@ ambiguous_symbol (const char *name, gfc_symtree * st) 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; @@ -1782,7 +2338,9 @@ gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag, 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; @@ -1806,8 +2364,8 @@ gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag, /* 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; @@ -1826,7 +2384,7 @@ gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag, /* 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) @@ -1852,7 +2410,7 @@ save_symbol_data (gfc_symbol * sym) 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; @@ -1883,8 +2441,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) } 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; @@ -1892,7 +2452,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) p = st->n.sym; - if (p->ns != ns && (!p->attr.function || ns->proc_name != p)) + if (p->ns != ns && (!p->attr.function || ns->proc_name != p) + && !(ns->proc_name + && ns->proc_name->attr.if_source == IFSRC_IFBODY + && (ns->has_import_set || p->attr.imported))) { /* Symbol is from another namespace. */ gfc_error ("Symbol '%s' at %C has already been host associated", @@ -1912,12 +2475,11 @@ gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) 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; @@ -1934,7 +2496,7 @@ gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result) 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; @@ -1943,7 +2505,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result) if (st != NULL) { save_symbol_data (st->n.sym); - *result = st; return i; } @@ -1966,7 +2527,7 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result) 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; @@ -1985,7 +2546,7 @@ gfc_get_ha_symbol (const char *name, gfc_symbol ** result) 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) @@ -2021,7 +2582,34 @@ gfc_undo_symbols (void) if (p->new) { /* Symbol was new. */ - delete_symtree (&p->ns->sym_root, p->name); + if (p->attr.in_common && p->common_block->head) + { + /* If the symbol was added to any common block, it + needs to be removed to stop the resolver looking + for a (possibly) dead symbol. */ + + if (p->common_block->head == p) + p->common_block->head = p->common_next; + else + { + gfc_symbol *cparent, *csym; + + cparent = p->common_block->head; + csym = cparent->common_next; + + while (csym != p) + { + cparent = csym; + csym = csym->common_next; + } + + gcc_assert(cparent->common_next == p); + + cparent->common_next = csym->common_next; + } + } + + gfc_delete_symtree (&p->ns->sym_root, p->name); p->refs--; if (p->refs < 0) @@ -2063,7 +2651,6 @@ gfc_undo_symbols (void) } else { - if (p->namelist_tail != old->namelist_tail) { gfc_free_namelist (old->namelist_tail); @@ -2088,6 +2675,33 @@ gfc_undo_symbols (void) } +/* 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. */ @@ -2102,15 +2716,37 @@ gfc_commit_symbols (void) 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); } @@ -2134,7 +2770,7 @@ free_common_tree (gfc_symtree * common_tree) 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) @@ -2154,7 +2790,7 @@ free_uop_tree (gfc_symtree * uop_tree) 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; @@ -2189,12 +2825,54 @@ free_sym_tree (gfc_symtree * sym_tree) } +/* 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; @@ -2224,6 +2902,7 @@ gfc_free_namespace (gfc_namespace * ns) 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]); @@ -2237,7 +2916,6 @@ gfc_free_namespace (gfc_namespace * ns) { q = p; p = p->sibling; - gfc_free_namespace (q); } } @@ -2257,13 +2935,14 @@ gfc_symbol_done_2 (void) 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; @@ -2273,32 +2952,32 @@ clear_sym_mark (gfc_symtree * st) /* 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) - { - (*func) (st); + if (!st) + return; - gfc_traverse_symtree (st->left, func); - gfc_traverse_symtree (st->right, func); - } + gfc_traverse_symtree (st->left, func); + (*func) (st); + gfc_traverse_symtree (st->right, func); } /* 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) return; + traverse_ns (st->left, func); + if (st->n.sym->mark == 0) (*func) (st->n.sym); st->n.sym->mark = 1; - traverse_ns (st->left, func); traverse_ns (st->right, func); } @@ -2307,7 +2986,7 @@ traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *)) 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); @@ -2316,10 +2995,48 @@ gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *)) } +/* Return TRUE when name is the name of an intrinsic type. */ + +bool +gfc_is_intrinsic_typename (const char *name) +{ + if (strcmp (name, "integer") == 0 + || strcmp (name, "real") == 0 + || strcmp (name, "character") == 0 + || strcmp (name, "logical") == 0 + || strcmp (name, "complex") == 0 + || strcmp (name, "doubleprecision") == 0 + || strcmp (name, "doublecomplex") == 0) + return true; + else + return false; +} + + +/* Return TRUE if the symbol is an automatic variable. */ + +static bool +gfc_is_var_automatic (gfc_symbol *sym) +{ + /* Pointer and allocatable variables are never automatic. */ + if (sym->attr.pointer || sym->attr.allocatable) + return false; + /* Check for arrays with non-constant size. */ + if (sym->attr.dimension && sym->as + && !gfc_is_compile_time_shape (sym->as)) + return true; + /* Check for non-constant length character variables. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.cl + && !gfc_is_constant_expr (sym->ts.cl->length)) + return true; + return false; +} + /* 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) @@ -2329,7 +3046,9 @@ save_symbol (gfc_symbol * sym) || sym->attr.dummy || sym->attr.flavor != FL_VARIABLE) return; - + /* Automatic objects are not saved. */ + if (gfc_is_var_automatic (sym)) + return; gfc_add_save (&sym->attr, sym->name, &sym->declared_at); } @@ -2337,7 +3056,7 @@ save_symbol (gfc_symbol * sym) /* 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); @@ -2364,20 +3083,19 @@ gfc_symbol_state(void) { 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; } @@ -2386,13 +3104,13 @@ gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) /* 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); } @@ -2409,9 +3127,944 @@ gfc_get_gsymbol (const char *name) s = gfc_getmem (sizeof (gfc_gsymbol)); s->type = GSYM_UNKNOWN; - strcpy (s->name, name); + s->name = gfc_get_string (name); gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); 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; + /* Create a constructor with no expr, that way we can recognize if the user + tries to call the structure constructor for one of the iso_c_binding + derived types during resolution (resolve_structure_cons). */ + tmp_sym->value->value.constructor = gfc_get_constructor (); + /* Must declare c_null_ptr and c_null_funptr as having the + PARAMETER attribute so they can be used in init expressions. */ + tmp_sym->attr.flavor = FL_PARAMETER; + + return SUCCESS; +} + + +/* Add a formal argument, gfc_formal_arglist, to the + end of the given list of arguments. Set the reference to the + provided symbol, param_sym, in the argument. */ + +static void +add_formal_arg (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + gfc_formal_arglist *formal_arg, + gfc_symbol *param_sym) +{ + /* Put in list, either as first arg or at the tail (curr arg). */ + if (*head == NULL) + *head = *tail = formal_arg; + else + { + (*tail)->next = formal_arg; + (*tail) = formal_arg; + } + + (*tail)->sym = param_sym; + (*tail)->next = NULL; + + return; +} + + +/* Generates a symbol representing the CPTR argument to an + iso_c_binding procedure. Also, create a gfc_formal_arglist for the + CPTR and add it to the provided argument list. */ + +static void +gen_cptr_param (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + const char *module_name, + gfc_namespace *ns, const char *c_ptr_name, + int iso_c_sym_id) +{ + gfc_symbol *param_sym = NULL; + gfc_symbol *c_ptr_sym = NULL; + gfc_symtree *param_symtree = NULL; + gfc_formal_arglist *formal_arg = NULL; + const char *c_ptr_in; + const char *c_ptr_type = NULL; + + if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) + c_ptr_type = "_gfortran_iso_c_binding_c_funptr"; + else + c_ptr_type = "_gfortran_iso_c_binding_c_ptr"; + + if(c_ptr_name == NULL) + c_ptr_in = "gfc_cptr__"; + else + c_ptr_in = c_ptr_name; + gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree); + if (param_symtree != NULL) + param_sym = param_symtree->n.sym; + else + gfc_internal_error ("gen_cptr_param(): Unable to " + "create symbol for %s", c_ptr_in); + + /* Set up the appropriate fields for the new c_ptr param sym. */ + param_sym->refs++; + param_sym->attr.flavor = FL_DERIVED; + param_sym->ts.type = BT_DERIVED; + param_sym->attr.intent = INTENT_IN; + param_sym->attr.dummy = 1; + + /* This will pass the ptr to the iso_c routines as a (void *). */ + param_sym->attr.value = 1; + param_sym->attr.use_assoc = 1; + + /* Get the symbol for c_ptr or c_funptr, no matter what it's name is + (user renamed). */ + if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) + c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); + else + c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR); + if (c_ptr_sym == NULL) + { + /* This can happen if the user did not define c_ptr but they are + trying to use one of the iso_c_binding functions that need it. */ + if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) + generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR, + (const char *)c_ptr_type); + else + generate_isocbinding_symbol (module_name, ISOCBINDING_PTR, + (const char *)c_ptr_type); + + gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym)); + } + + param_sym->ts.derived = c_ptr_sym; + param_sym->module = gfc_get_string (module_name); + + /* Make new formal arg. */ + formal_arg = gfc_get_formal_arglist (); + /* Add arg to list of formal args (the CPTR arg). */ + add_formal_arg (head, tail, formal_arg, param_sym); +} + + +/* Generates a symbol representing the FPTR argument to an + iso_c_binding procedure. Also, create a gfc_formal_arglist for the + FPTR and add it to the provided argument list. */ + +static void +gen_fptr_param (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + const char *module_name, + gfc_namespace *ns, const char *f_ptr_name) +{ + gfc_symbol *param_sym = NULL; + gfc_symtree *param_symtree = NULL; + gfc_formal_arglist *formal_arg = NULL; + const char *f_ptr_out = "gfc_fptr__"; + + if (f_ptr_name != NULL) + f_ptr_out = f_ptr_name; + + gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree); + if (param_symtree != NULL) + param_sym = param_symtree->n.sym; + else + gfc_internal_error ("generateFPtrParam(): Unable to " + "create symbol for %s", f_ptr_out); + + /* Set up the necessary fields for the fptr output param sym. */ + param_sym->refs++; + param_sym->attr.pointer = 1; + param_sym->attr.dummy = 1; + param_sym->attr.use_assoc = 1; + + /* ISO C Binding type to allow any pointer type as actual param. */ + param_sym->ts.type = BT_VOID; + param_sym->module = gfc_get_string (module_name); + + /* Make the arg. */ + formal_arg = gfc_get_formal_arglist (); + /* Add arg to list of formal args. */ + add_formal_arg (head, tail, formal_arg, param_sym); +} + + +/* Generates a symbol representing the optional SHAPE argument for the + iso_c_binding c_f_pointer() procedure. Also, create a + gfc_formal_arglist for the SHAPE and add it to the provided + argument list. */ + +static void +gen_shape_param (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + const char *module_name, + gfc_namespace *ns, const char *shape_param_name) +{ + gfc_symbol *param_sym = NULL; + gfc_symtree *param_symtree = NULL; + gfc_formal_arglist *formal_arg = NULL; + const char *shape_param = "gfc_shape_array__"; + int i; + + if (shape_param_name != NULL) + shape_param = shape_param_name; + + gfc_get_sym_tree (shape_param, ns, ¶m_symtree); + if (param_symtree != NULL) + param_sym = param_symtree->n.sym; + else + gfc_internal_error ("generateShapeParam(): Unable to " + "create symbol for %s", shape_param); + + /* Set up the necessary fields for the shape input param sym. */ + param_sym->refs++; + param_sym->attr.dummy = 1; + param_sym->attr.use_assoc = 1; + + /* Integer array, rank 1, describing the shape of the object. Make it's + type BT_VOID initially so we can accept any type/kind combination of + integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it + of BT_INTEGER type. */ + param_sym->ts.type = BT_VOID; + + /* Initialize the kind to default integer. However, it will be overridden + during resolution to match the kind of the SHAPE parameter given as + the actual argument (to allow for any valid integer kind). */ + param_sym->ts.kind = gfc_default_integer_kind; + param_sym->as = gfc_get_array_spec (); + + /* Clear out the dimension info for the array. */ + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + param_sym->as->lower[i] = NULL; + param_sym->as->upper[i] = NULL; + } + param_sym->as->rank = 1; + param_sym->as->lower[0] = gfc_int_expr (1); + + /* The extent is unknown until we get it. The length give us + the rank the incoming pointer. */ + param_sym->as->type = AS_ASSUMED_SHAPE; + + /* The arg is also optional; it is required iff the second arg + (fptr) is to an array, otherwise, it's ignored. */ + param_sym->attr.optional = 1; + param_sym->attr.intent = INTENT_IN; + param_sym->attr.dimension = 1; + param_sym->module = gfc_get_string (module_name); + + /* Make the arg. */ + formal_arg = gfc_get_formal_arglist (); + /* Add arg to list of formal args. */ + add_formal_arg (head, tail, formal_arg, param_sym); +} + +/* Add a procedure interface to the given symbol (i.e., store a + reference to the list of formal arguments). */ + +static void +add_proc_interface (gfc_symbol *sym, ifsrc source, + gfc_formal_arglist *formal) +{ + + sym->formal = formal; + sym->attr.if_source = source; +} + +/* Copy the formal args from an existing symbol, src, into a new + symbol, dest. New formal args are created, and the description of + each arg is set according to the existing ones. This function is + used when creating procedure declaration variables from a procedure + declaration statement (see match_proc_decl()) to create the formal + args based on the args of a given named interface. */ + +void copy_formal_args (gfc_symbol *dest, gfc_symbol *src) +{ + gfc_formal_arglist *head = NULL; + gfc_formal_arglist *tail = NULL; + gfc_formal_arglist *formal_arg = NULL; + gfc_formal_arglist *curr_arg = NULL; + gfc_formal_arglist *formal_prev = NULL; + /* Save current namespace so we can change it for formal args. */ + gfc_namespace *parent_ns = gfc_current_ns; + + /* Create a new namespace, which will be the formal ns (namespace + of the formal args). */ + gfc_current_ns = gfc_get_namespace (parent_ns, 0); + gfc_current_ns->proc_name = dest; + + for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) + { + formal_arg = gfc_get_formal_arglist (); + gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym)); + + /* May need to copy more info for the symbol. */ + formal_arg->sym->attr = curr_arg->sym->attr; + formal_arg->sym->ts = curr_arg->sym->ts; + + /* If this isn't the first arg, set up the next ptr. For the + last arg built, the formal_arg->next will never get set to + anything other than NULL. */ + if (formal_prev != NULL) + formal_prev->next = formal_arg; + else + formal_arg->next = NULL; + + formal_prev = formal_arg; + + /* Add arg to list of formal args. */ + add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + } + + /* Add the interface to the symbol. */ + add_proc_interface (dest, IFSRC_DECL, head); + + /* Store the formal namespace information. */ + if (dest->formal != NULL) + /* The current ns should be that for the dest proc. */ + dest->formal_ns = gfc_current_ns; + /* Restore the current namespace to what it was on entry. */ + gfc_current_ns = parent_ns; +} + +/* Builds the parameter list for the iso_c_binding procedure + c_f_pointer or c_f_procpointer. The old_sym typically refers to a + 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'; + tmp_sym->ts.cl = gfc_get_charlen (); + tmp_sym->ts.cl->length = gfc_int_expr (1); + + /* May not need this in both attr and ts, but do need in + attr for writing module file. */ + 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); + new_symtree->n.sym->from_intmod = old_sym->from_intmod; + new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id; + /* Build the formal arg list. */ + build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg); + + gfc_commit_symbol (new_symtree->n.sym); + + return new_symtree->n.sym; +} +