1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
37 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
38 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
39 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
43 const mstring procedures[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
46 minit ("MODULE-PROC", PROC_MODULE),
47 minit ("INTERNAL-PROC", PROC_INTERNAL),
48 minit ("DUMMY-PROC", PROC_DUMMY),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
55 const mstring intents[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
58 minit ("IN", INTENT_IN),
59 minit ("OUT", INTENT_OUT),
60 minit ("INOUT", INTENT_INOUT),
64 const mstring access_types[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
67 minit ("PUBLIC", ACCESS_PUBLIC),
68 minit ("PRIVATE", ACCESS_PRIVATE),
72 const mstring ifsrc_types[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN),
75 minit ("DECL", IFSRC_DECL),
76 minit ("BODY", IFSRC_IFBODY),
77 minit ("USAGE", IFSRC_USAGE)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order = 1;
87 gfc_namespace *gfc_current_ns;
89 gfc_gsymbol *gfc_gsym_root = NULL;
91 static gfc_symbol *changed_syms = NULL;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag[GFC_LETTERS];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 for (i = 0; i < GFC_LETTERS; i++)
111 gfc_clear_ts (&gfc_current_ns->default_type[i]);
112 gfc_current_ns->set_flag[i] = 1;
117 /* Reset the implicit range flags. */
120 gfc_clear_new_implicit (void)
124 for (i = 0; i < GFC_LETTERS; i++)
129 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
132 gfc_add_new_implicit_range (int c1, int c2)
139 for (i = c1; i <= c2; i++)
143 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
155 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
156 the new implicit types back into the existing types will work. */
159 gfc_merge_new_implicit (gfc_typespec * ts)
163 for (i = 0; i < GFC_LETTERS; i++)
168 if (gfc_current_ns->set_flag[i])
170 gfc_error ("Letter %c already has an IMPLICIT type at %C",
174 gfc_current_ns->default_type[i] = *ts;
175 gfc_current_ns->set_flag[i] = 1;
182 /* Given a symbol, return a pointer to the typespec for its default type. */
185 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
189 letter = sym->name[0];
190 if (letter < 'a' || letter > 'z')
191 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
196 return &ns->default_type[letter - 'a'];
200 /* Given a pointer to a symbol, set its type according to the first
201 letter of its name. Fails if the letter in question has no default
205 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
209 if (sym->ts.type != BT_UNKNOWN)
210 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
212 ts = gfc_get_default_type (sym, ns);
214 if (ts->type == BT_UNKNOWN)
217 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
224 sym->attr.implicit_type = 1;
230 /******************** Symbol attribute stuff *********************/
232 /* This is a generic conflict-checker. We do this to avoid having a
233 single conflict in two places. */
235 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
236 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
239 check_conflict (symbol_attribute * attr, const char * name, locus * where)
241 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
242 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
243 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
244 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
245 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
246 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
247 *function = "FUNCTION", *subroutine = "SUBROUTINE",
248 *dimension = "DIMENSION";
253 where = &gfc_current_locus;
255 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
262 /* Check for attributes not allowed in a BLOCK DATA. */
263 if (gfc_current_state () == COMP_BLOCK_DATA)
267 if (attr->allocatable)
273 if (attr->access == ACCESS_PRIVATE)
275 if (attr->access == ACCESS_PUBLIC)
277 if (attr->intent != INTENT_UNKNOWN)
283 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
290 conf (pointer, target);
291 conf (pointer, external);
292 conf (pointer, intrinsic);
293 conf (target, external);
294 conf (target, intrinsic);
295 conf (external, dimension); /* See Fortran 95's R504. */
297 conf (external, intrinsic);
298 conf (allocatable, pointer);
299 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
300 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
301 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
302 conf (elemental, recursive);
304 conf (in_common, dummy);
305 conf (in_common, allocatable);
306 conf (in_common, result);
307 conf (dummy, result);
309 conf (in_namelist, pointer);
310 conf (in_namelist, allocatable);
312 conf (entry, result);
314 conf (function, subroutine);
316 a1 = gfc_code2string (flavors, attr->flavor);
318 if (attr->in_namelist
319 && attr->flavor != FL_VARIABLE
320 && attr->flavor != FL_UNKNOWN)
327 switch (attr->flavor)
354 if (attr->subroutine)
367 case PROC_ST_FUNCTION:
400 if (attr->intent != INTENT_UNKNOWN)
429 gfc_error ("%s attribute conflicts with %s attribute at %L",
432 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
433 a1, a2, name, where);
442 /* Mark a symbol as referenced. */
445 gfc_set_sym_referenced (gfc_symbol * sym)
447 if (sym->attr.referenced)
450 sym->attr.referenced = 1;
452 /* Remember which order dummy variables are accessed in. */
454 sym->dummy_order = next_dummy_order++;
458 /* Common subroutine called by attribute changing subroutines in order
459 to prevent them from changing a symbol that has been
460 use-associated. Returns zero if it is OK to change the symbol,
464 check_used (symbol_attribute * attr, const char * name, locus * where)
467 if (attr->use_assoc == 0)
471 where = &gfc_current_locus;
474 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
477 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
484 /* Used to prevent changing the attributes of a symbol after it has been
485 used. This check is only done for dummy variables as only these can be
486 used in specification expressions. Applying this to all symbols causes
487 an error when we reach the body of a contained function. */
490 check_done (symbol_attribute * attr, locus * where)
493 if (!(attr->dummy && attr->referenced))
497 where = &gfc_current_locus;
499 gfc_error ("Cannot change attributes of symbol at %L"
500 " after it has been used", where);
506 /* Generate an error because of a duplicate attribute. */
509 duplicate_attr (const char *attr, locus * where)
513 where = &gfc_current_locus;
515 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
520 gfc_add_allocatable (symbol_attribute * attr, locus * where)
523 if (check_used (attr, NULL, where) || check_done (attr, where))
526 if (attr->allocatable)
528 duplicate_attr ("ALLOCATABLE", where);
532 attr->allocatable = 1;
533 return check_conflict (attr, NULL, where);
538 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
541 if (check_used (attr, name, where) || check_done (attr, where))
546 duplicate_attr ("DIMENSION", where);
551 return check_conflict (attr, name, where);
556 gfc_add_external (symbol_attribute * attr, locus * where)
559 if (check_used (attr, NULL, where) || check_done (attr, where))
564 duplicate_attr ("EXTERNAL", where);
570 return check_conflict (attr, NULL, where);
575 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
578 if (check_used (attr, NULL, where) || check_done (attr, where))
583 duplicate_attr ("INTRINSIC", where);
589 return check_conflict (attr, NULL, where);
594 gfc_add_optional (symbol_attribute * attr, locus * where)
597 if (check_used (attr, NULL, where) || check_done (attr, where))
602 duplicate_attr ("OPTIONAL", where);
607 return check_conflict (attr, NULL, where);
612 gfc_add_pointer (symbol_attribute * attr, locus * where)
615 if (check_used (attr, NULL, where) || check_done (attr, where))
619 return check_conflict (attr, NULL, where);
624 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
627 if (check_used (attr, name, where) || check_done (attr, where))
631 return check_conflict (attr, name, where);
636 gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
639 if (check_used (attr, name, where))
645 ("SAVE attribute at %L cannot be specified in a PURE procedure",
652 duplicate_attr ("SAVE", where);
657 return check_conflict (attr, name, where);
662 gfc_add_target (symbol_attribute * attr, locus * where)
665 if (check_used (attr, NULL, where) || check_done (attr, where))
670 duplicate_attr ("TARGET", where);
675 return check_conflict (attr, NULL, where);
680 gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
683 if (check_used (attr, name, where))
686 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
688 return check_conflict (attr, name, where);
693 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
696 if (check_used (attr, name, where) || check_done (attr, where))
699 /* Duplicate attribute already checked for. */
701 if (check_conflict (attr, name, where) == FAILURE)
704 if (attr->flavor == FL_VARIABLE)
707 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
712 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
715 if (check_used (attr, name, where))
719 return check_conflict (attr, name, where);
724 gfc_add_in_namelist (symbol_attribute * attr, const char *name,
728 attr->in_namelist = 1;
729 return check_conflict (attr, name, where);
734 gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
737 if (check_used (attr, name, where))
741 return check_conflict (attr, name, where);
746 gfc_add_elemental (symbol_attribute * attr, locus * where)
749 if (check_used (attr, NULL, where) || check_done (attr, where))
753 return check_conflict (attr, NULL, where);
758 gfc_add_pure (symbol_attribute * attr, locus * where)
761 if (check_used (attr, NULL, where) || check_done (attr, where))
765 return check_conflict (attr, NULL, where);
770 gfc_add_recursive (symbol_attribute * attr, locus * where)
773 if (check_used (attr, NULL, where) || check_done (attr, where))
777 return check_conflict (attr, NULL, where);
782 gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
785 if (check_used (attr, name, where))
790 duplicate_attr ("ENTRY", where);
795 return check_conflict (attr, name, where);
800 gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
803 if (attr->flavor != FL_PROCEDURE
804 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
808 return check_conflict (attr, name, where);
813 gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
816 if (attr->flavor != FL_PROCEDURE
817 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
820 attr->subroutine = 1;
821 return check_conflict (attr, name, where);
826 gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
829 if (attr->flavor != FL_PROCEDURE
830 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
834 return check_conflict (attr, name, where);
838 /* Flavors are special because some flavors are not what Fortran
839 considers attributes and can be reaffirmed multiple times. */
842 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
846 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
847 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
848 || f == FL_NAMELIST) && check_used (attr, name, where))
851 if (attr->flavor == f && f == FL_VARIABLE)
854 if (attr->flavor != FL_UNKNOWN)
857 where = &gfc_current_locus;
859 gfc_error ("%s attribute conflicts with %s attribute at %L",
860 gfc_code2string (flavors, attr->flavor),
861 gfc_code2string (flavors, f), where);
868 return check_conflict (attr, name, where);
873 gfc_add_procedure (symbol_attribute * attr, procedure_type t,
874 const char *name, locus * where)
877 if (check_used (attr, name, where) || check_done (attr, where))
880 if (attr->flavor != FL_PROCEDURE
881 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
885 where = &gfc_current_locus;
887 if (attr->proc != PROC_UNKNOWN)
889 gfc_error ("%s procedure at %L is already %s %s procedure",
890 gfc_code2string (procedures, t), where,
891 gfc_article (gfc_code2string (procedures, attr->proc)),
892 gfc_code2string (procedures, attr->proc));
899 /* Statement functions are always scalar and functions. */
900 if (t == PROC_ST_FUNCTION
901 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
905 return check_conflict (attr, name, where);
910 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
913 if (check_used (attr, NULL, where))
916 if (attr->intent == INTENT_UNKNOWN)
918 attr->intent = intent;
919 return check_conflict (attr, NULL, where);
923 where = &gfc_current_locus;
925 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
926 gfc_intent_string (attr->intent),
927 gfc_intent_string (intent), where);
933 /* No checks for use-association in public and private statements. */
936 gfc_add_access (symbol_attribute * attr, gfc_access access,
937 const char *name, locus * where)
940 if (attr->access == ACCESS_UNKNOWN)
942 attr->access = access;
943 return check_conflict (attr, name, where);
947 where = &gfc_current_locus;
948 gfc_error ("ACCESS specification at %L was already specified", where);
955 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
956 gfc_formal_arglist * formal, locus * where)
959 if (check_used (&sym->attr, sym->name, where))
963 where = &gfc_current_locus;
965 if (sym->attr.if_source != IFSRC_UNKNOWN
966 && sym->attr.if_source != IFSRC_DECL)
968 gfc_error ("Symbol '%s' at %L already has an explicit interface",
973 sym->formal = formal;
974 sym->attr.if_source = source;
980 /* Add a type to a symbol. */
983 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
987 /* TODO: This is legal if it is reaffirming an implicit type.
988 if (check_done (&sym->attr, where))
992 where = &gfc_current_locus;
994 if (sym->ts.type != BT_UNKNOWN)
996 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
997 where, gfc_basic_typename (sym->ts.type));
1001 flavor = sym->attr.flavor;
1003 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1004 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1005 && sym->attr.subroutine)
1006 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1008 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1017 /* Clears all attributes. */
1020 gfc_clear_attr (symbol_attribute * attr)
1022 memset (attr, 0, sizeof(symbol_attribute));
1026 /* Check for missing attributes in the new symbol. Currently does
1027 nothing, but it's not clear that it is unnecessary yet. */
1030 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1031 locus * where ATTRIBUTE_UNUSED)
1038 /* Copy an attribute to a symbol attribute, bit by bit. Some
1039 attributes have a lot of side-effects but cannot be present given
1040 where we are called from, so we ignore some bits. */
1043 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1046 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1049 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1051 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1053 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1055 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1057 if (src->target && gfc_add_target (dest, where) == FAILURE)
1059 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1061 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1066 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1069 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1072 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1074 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1076 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1079 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1081 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1083 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1085 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1088 if (src->flavor != FL_UNKNOWN
1089 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1092 if (src->intent != INTENT_UNKNOWN
1093 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1096 if (src->access != ACCESS_UNKNOWN
1097 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1100 if (gfc_missing_attr (dest, where) == FAILURE)
1103 /* The subroutines that set these bits also cause flavors to be set,
1104 and that has already happened in the original, so don't let it
1109 dest->intrinsic = 1;
1118 /************** Component name management ************/
1120 /* Component names of a derived type form their own little namespaces
1121 that are separate from all other spaces. The space is composed of
1122 a singly linked list of gfc_component structures whose head is
1123 located in the parent symbol. */
1126 /* Add a component name to a symbol. The call fails if the name is
1127 already present. On success, the component pointer is modified to
1128 point to the additional component structure. */
1131 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1133 gfc_component *p, *tail;
1137 for (p = sym->components; p; p = p->next)
1139 if (strcmp (p->name, name) == 0)
1141 gfc_error ("Component '%s' at %C already declared at %L",
1149 /* Allocate a new component. */
1150 p = gfc_get_component ();
1153 sym->components = p;
1157 strcpy (p->name, name);
1158 p->loc = gfc_current_locus;
1165 /* Recursive function to switch derived types of all symbol in a
1169 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1177 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1178 sym->ts.derived = to;
1180 switch_types (st->left, from, to);
1181 switch_types (st->right, from, to);
1185 /* This subroutine is called when a derived type is used in order to
1186 make the final determination about which version to use. The
1187 standard requires that a type be defined before it is 'used', but
1188 such types can appear in IMPLICIT statements before the actual
1189 definition. 'Using' in this context means declaring a variable to
1190 be that type or using the type constructor.
1192 If a type is used and the components haven't been defined, then we
1193 have to have a derived type in a parent unit. We find the node in
1194 the other namespace and point the symtree node in this namespace to
1195 that node. Further reference to this name point to the correct
1196 node. If we can't find the node in a parent namespace, then we have
1199 This subroutine takes a pointer to a symbol node and returns a
1200 pointer to the translated node or NULL for an error. Usually there
1201 is no translation and we return the node we were passed. */
1204 gfc_use_derived (gfc_symbol * sym)
1211 if (sym->components != NULL)
1212 return sym; /* Already defined. */
1214 if (sym->ns->parent == NULL)
1217 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1219 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1223 if (s == NULL || s->attr.flavor != FL_DERIVED)
1226 /* Get rid of symbol sym, translating all references to s. */
1227 for (i = 0; i < GFC_LETTERS; i++)
1229 t = &sym->ns->default_type[i];
1230 if (t->derived == sym)
1234 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1239 /* Unlink from list of modified symbols. */
1240 if (changed_syms == sym)
1241 changed_syms = sym->tlink;
1243 for (p = changed_syms; p; p = p->tlink)
1244 if (p->tlink == sym)
1246 p->tlink = sym->tlink;
1250 switch_types (sym->ns->sym_root, sym, s);
1252 /* TODO: Also have to replace sym -> s in other lists like
1253 namelists, common lists and interface lists. */
1254 gfc_free_symbol (sym);
1259 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1265 /* Given a derived type node and a component name, try to locate the
1266 component structure. Returns the NULL pointer if the component is
1267 not found or the components are private. */
1270 gfc_find_component (gfc_symbol * sym, const char *name)
1277 sym = gfc_use_derived (sym);
1282 for (p = sym->components; p; p = p->next)
1283 if (strcmp (p->name, name) == 0)
1287 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1291 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1293 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1303 /* Given a symbol, free all of the component structures and everything
1307 free_components (gfc_component * p)
1315 gfc_free_array_spec (p->as);
1316 gfc_free_expr (p->initializer);
1323 /* Set component attributes from a standard symbol attribute
1327 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1330 c->dimension = attr->dimension;
1331 c->pointer = attr->pointer;
1335 /* Get a standard symbol attribute structure given the component
1339 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1342 gfc_clear_attr (attr);
1343 attr->dimension = c->dimension;
1344 attr->pointer = c->pointer;
1348 /******************** Statement label management ********************/
1350 /* Free a single gfc_st_label structure, making sure the list is not
1351 messed up. This function is called only when some parse error
1355 gfc_free_st_label (gfc_st_label * l)
1362 (l->prev->next = l->next);
1365 (l->next->prev = l->prev);
1367 if (l->format != NULL)
1368 gfc_free_expr (l->format);
1372 /* Free a whole list of gfc_st_label structures. */
1375 free_st_labels (gfc_st_label * l1)
1382 if (l1->format != NULL)
1383 gfc_free_expr (l1->format);
1389 /* Given a label number, search for and return a pointer to the label
1390 structure, creating it if it does not exist. */
1393 gfc_get_st_label (int labelno)
1397 /* First see if the label is already in this namespace. */
1398 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1399 if (lp->value == labelno)
1404 lp = gfc_getmem (sizeof (gfc_st_label));
1406 lp->value = labelno;
1407 lp->defined = ST_LABEL_UNKNOWN;
1408 lp->referenced = ST_LABEL_UNKNOWN;
1411 lp->next = gfc_current_ns->st_labels;
1412 if (gfc_current_ns->st_labels)
1413 gfc_current_ns->st_labels->prev = lp;
1414 gfc_current_ns->st_labels = lp;
1420 /* Called when a statement with a statement label is about to be
1421 accepted. We add the label to the list of the current namespace,
1422 making sure it hasn't been defined previously and referenced
1426 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1430 labelno = lp->value;
1432 if (lp->defined != ST_LABEL_UNKNOWN)
1433 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1434 &lp->where, label_locus);
1437 lp->where = *label_locus;
1441 case ST_LABEL_FORMAT:
1442 if (lp->referenced == ST_LABEL_TARGET)
1443 gfc_error ("Label %d at %C already referenced as branch target",
1446 lp->defined = ST_LABEL_FORMAT;
1450 case ST_LABEL_TARGET:
1451 if (lp->referenced == ST_LABEL_FORMAT)
1452 gfc_error ("Label %d at %C already referenced as a format label",
1455 lp->defined = ST_LABEL_TARGET;
1460 lp->defined = ST_LABEL_BAD_TARGET;
1461 lp->referenced = ST_LABEL_BAD_TARGET;
1467 /* Reference a label. Given a label and its type, see if that
1468 reference is consistent with what is known about that label,
1469 updating the unknown state. Returns FAILURE if something goes
1473 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1475 gfc_sl_type label_type;
1482 labelno = lp->value;
1484 if (lp->defined != ST_LABEL_UNKNOWN)
1485 label_type = lp->defined;
1488 label_type = lp->referenced;
1489 lp->where = gfc_current_locus;
1492 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1494 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1499 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1500 && type == ST_LABEL_FORMAT)
1502 gfc_error ("Label %d at %C previously used as branch target", labelno);
1507 lp->referenced = type;
1515 /************** Symbol table management subroutines ****************/
1517 /* Basic details: Fortran 95 requires a potentially unlimited number
1518 of distinct namespaces when compiling a program unit. This case
1519 occurs during a compilation of internal subprograms because all of
1520 the internal subprograms must be read before we can start
1521 generating code for the host.
1523 Given the tricky nature of the Fortran grammar, we must be able to
1524 undo changes made to a symbol table if the current interpretation
1525 of a statement is found to be incorrect. Whenever a symbol is
1526 looked up, we make a copy of it and link to it. All of these
1527 symbols are kept in a singly linked list so that we can commit or
1528 undo the changes at a later time.
1530 A symtree may point to a symbol node outside of its namespace. In
1531 this case, that symbol has been used as a host associated variable
1532 at some previous time. */
1534 /* Allocate a new namespace structure. */
1537 gfc_get_namespace (gfc_namespace * parent)
1541 gfc_intrinsic_op in;
1544 ns = gfc_getmem (sizeof (gfc_namespace));
1545 ns->sym_root = NULL;
1546 ns->uop_root = NULL;
1547 ns->default_access = ACCESS_UNKNOWN;
1548 ns->parent = parent;
1550 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1551 ns->operator_access[in] = ACCESS_UNKNOWN;
1553 /* Initialize default implicit types. */
1554 for (i = 'a'; i <= 'z'; i++)
1556 ns->set_flag[i - 'a'] = 0;
1557 ts = &ns->default_type[i - 'a'];
1559 if (ns->parent != NULL)
1561 /* Copy parent settings */
1562 *ts = ns->parent->default_type[i - 'a'];
1566 if (gfc_option.flag_implicit_none != 0)
1572 if ('i' <= i && i <= 'n')
1574 ts->type = BT_INTEGER;
1575 ts->kind = gfc_default_integer_kind;
1580 ts->kind = gfc_default_real_kind;
1590 /* Comparison function for symtree nodes. */
1593 compare_symtree (void * _st1, void * _st2)
1595 gfc_symtree *st1, *st2;
1597 st1 = (gfc_symtree *) _st1;
1598 st2 = (gfc_symtree *) _st2;
1600 return strcmp (st1->name, st2->name);
1604 /* Allocate a new symtree node and associate it with the new symbol. */
1607 gfc_new_symtree (gfc_symtree ** root, const char *name)
1611 st = gfc_getmem (sizeof (gfc_symtree));
1612 strcpy (st->name, name);
1614 gfc_insert_bbt (root, st, compare_symtree);
1619 /* Delete a symbol from the tree. Does not free the symbol itself! */
1622 delete_symtree (gfc_symtree ** root, const char *name)
1624 gfc_symtree st, *st0;
1626 st0 = gfc_find_symtree (*root, name);
1628 strcpy (st.name, name);
1629 gfc_delete_bbt (root, &st, compare_symtree);
1635 /* Given a root symtree node and a name, try to find the symbol within
1636 the namespace. Returns NULL if the symbol is not found. */
1639 gfc_find_symtree (gfc_symtree * st, const char *name)
1645 c = strcmp (name, st->name);
1649 st = (c < 0) ? st->left : st->right;
1656 /* Given a name find a user operator node, creating it if it doesn't
1657 exist. These are much simpler than symbols because they can't be
1658 ambiguous with one another. */
1661 gfc_get_uop (const char *name)
1666 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1670 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1672 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1673 strcpy (uop->name, name);
1674 uop->access = ACCESS_UNKNOWN;
1675 uop->ns = gfc_current_ns;
1681 /* Given a name find the user operator node. Returns NULL if it does
1685 gfc_find_uop (const char *name, gfc_namespace * ns)
1690 ns = gfc_current_ns;
1692 st = gfc_find_symtree (ns->uop_root, name);
1693 return (st == NULL) ? NULL : st->n.uop;
1697 /* Remove a gfc_symbol structure and everything it points to. */
1700 gfc_free_symbol (gfc_symbol * sym)
1706 gfc_free_array_spec (sym->as);
1708 free_components (sym->components);
1710 gfc_free_expr (sym->value);
1712 gfc_free_namelist (sym->namelist);
1714 gfc_free_namespace (sym->formal_ns);
1716 gfc_free_interface (sym->generic);
1718 gfc_free_formal_arglist (sym->formal);
1724 /* Allocate and initialize a new symbol node. */
1727 gfc_new_symbol (const char *name, gfc_namespace * ns)
1731 p = gfc_getmem (sizeof (gfc_symbol));
1733 gfc_clear_ts (&p->ts);
1734 gfc_clear_attr (&p->attr);
1737 p->declared_at = gfc_current_locus;
1739 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1740 gfc_internal_error ("new_symbol(): Symbol name too long");
1742 strcpy (p->name, name);
1747 /* Generate an error if a symbol is ambiguous. */
1750 ambiguous_symbol (const char *name, gfc_symtree * st)
1753 if (st->n.sym->module[0])
1754 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1755 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1757 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1758 "from current program unit", name, st->n.sym->name);
1762 /* Search for a symtree starting in the current namespace, resorting to
1763 any parent namespaces if requested by a nonzero parent_flag.
1764 Returns nonzero if the name is ambiguous. */
1767 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1768 gfc_symtree ** result)
1773 ns = gfc_current_ns;
1777 st = gfc_find_symtree (ns->sym_root, name);
1783 ambiguous_symbol (name, st);
1802 /* Same, but returns the symbol instead. */
1805 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1806 gfc_symbol ** result)
1811 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1816 *result = st->n.sym;
1822 /* Save symbol with the information necessary to back it out. */
1825 save_symbol_data (gfc_symbol * sym)
1828 if (sym->new || sym->old_symbol != NULL)
1831 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1832 *(sym->old_symbol) = *sym;
1834 sym->tlink = changed_syms;
1839 /* Given a name, find a symbol, or create it if it does not exist yet
1840 in the current namespace. If the symbol is found we make sure that
1843 The integer return code indicates
1845 1 The symbol name was ambiguous
1846 2 The name meant to be established was already host associated.
1848 So if the return value is nonzero, then an error was issued. */
1851 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1856 /* This doesn't usually happen during resolution. */
1858 ns = gfc_current_ns;
1860 /* Try to find the symbol in ns. */
1861 st = gfc_find_symtree (ns->sym_root, name);
1865 /* If not there, create a new symbol. */
1866 p = gfc_new_symbol (name, ns);
1868 /* Add to the list of tentative symbols. */
1869 p->old_symbol = NULL;
1870 p->tlink = changed_syms;
1875 st = gfc_new_symtree (&ns->sym_root, name);
1882 /* Make sure the existing symbol is OK. */
1885 ambiguous_symbol (name, st);
1891 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1893 /* Symbol is from another namespace. */
1894 gfc_error ("Symbol '%s' at %C has already been host associated",
1901 /* Copy in case this symbol is changed. */
1902 save_symbol_data (p);
1911 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1917 i = gfc_get_sym_tree (name, ns, &st);
1922 *result = st->n.sym;
1929 /* Subroutine that searches for a symbol, creating it if it doesn't
1930 exist, but tries to host-associate the symbol if possible. */
1933 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1938 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1941 save_symbol_data (st->n.sym);
1947 if (gfc_current_ns->parent != NULL)
1949 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1960 return gfc_get_sym_tree (name, gfc_current_ns, result);
1965 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
1970 i = gfc_get_ha_sym_tree (name, &st);
1973 *result = st->n.sym;
1980 /* Return true if both symbols could refer to the same data object. Does
1981 not take account of aliasing due to equivalence statements. */
1984 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
1986 /* Aliasing isn't possible if the symbols have different base types. */
1987 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
1990 /* Pointers can point to other pointers, target objects and allocatable
1991 objects. Two allocatable objects cannot share the same storage. */
1992 if (lsym->attr.pointer
1993 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
1995 if (lsym->attr.target && rsym->attr.pointer)
1997 if (lsym->attr.allocatable && rsym->attr.pointer)
2004 /* Undoes all the changes made to symbols in the current statement.
2005 This subroutine is made simpler due to the fact that attributes are
2006 never removed once added. */
2009 gfc_undo_symbols (void)
2011 gfc_symbol *p, *q, *old;
2013 for (p = changed_syms; p; p = q)
2019 /* Symbol was new. */
2020 delete_symtree (&p->ns->sym_root, p->name);
2024 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2026 gfc_free_symbol (p);
2030 /* Restore previous state of symbol. Just copy simple stuff. */
2032 old = p->old_symbol;
2034 p->ts.type = old->ts.type;
2035 p->ts.kind = old->ts.kind;
2037 p->attr = old->attr;
2039 if (p->value != old->value)
2041 gfc_free_expr (old->value);
2045 if (p->as != old->as)
2048 gfc_free_array_spec (p->as);
2052 p->generic = old->generic;
2053 p->component_access = old->component_access;
2055 if (p->namelist != NULL && old->namelist == NULL)
2057 gfc_free_namelist (p->namelist);
2063 if (p->namelist_tail != old->namelist_tail)
2065 gfc_free_namelist (old->namelist_tail);
2066 old->namelist_tail->next = NULL;
2070 p->namelist_tail = old->namelist_tail;
2072 if (p->formal != old->formal)
2074 gfc_free_formal_arglist (p->formal);
2075 p->formal = old->formal;
2078 gfc_free (p->old_symbol);
2079 p->old_symbol = NULL;
2083 changed_syms = NULL;
2087 /* Makes the changes made in the current statement permanent-- gets
2088 rid of undo information. */
2091 gfc_commit_symbols (void)
2095 for (p = changed_syms; p; p = q)
2102 if (p->old_symbol != NULL)
2104 gfc_free (p->old_symbol);
2105 p->old_symbol = NULL;
2109 changed_syms = NULL;
2113 /* Recursive function that deletes an entire tree and all the common
2114 head structures it points to. */
2117 free_common_tree (gfc_symtree * common_tree)
2119 if (common_tree == NULL)
2122 free_common_tree (common_tree->left);
2123 free_common_tree (common_tree->right);
2125 gfc_free (common_tree);
2129 /* Recursive function that deletes an entire tree and all the user
2130 operator nodes that it contains. */
2133 free_uop_tree (gfc_symtree * uop_tree)
2136 if (uop_tree == NULL)
2139 free_uop_tree (uop_tree->left);
2140 free_uop_tree (uop_tree->right);
2142 gfc_free_interface (uop_tree->n.uop->operator);
2144 gfc_free (uop_tree->n.uop);
2145 gfc_free (uop_tree);
2149 /* Recursive function that deletes an entire tree and all the symbols
2150 that it contains. */
2153 free_sym_tree (gfc_symtree * sym_tree)
2158 if (sym_tree == NULL)
2161 free_sym_tree (sym_tree->left);
2162 free_sym_tree (sym_tree->right);
2164 sym = sym_tree->n.sym;
2168 gfc_internal_error ("free_sym_tree(): Negative refs");
2170 if (sym->formal_ns != NULL && sym->refs == 1)
2172 /* As formal_ns contains a reference to sym, delete formal_ns just
2173 before the deletion of sym. */
2174 ns = sym->formal_ns;
2175 sym->formal_ns = NULL;
2176 gfc_free_namespace (ns);
2178 else if (sym->refs == 0)
2180 /* Go ahead and delete the symbol. */
2181 gfc_free_symbol (sym);
2184 gfc_free (sym_tree);
2188 /* Free a namespace structure and everything below it. Interface
2189 lists associated with intrinsic operators are not freed. These are
2190 taken care of when a specific name is freed. */
2193 gfc_free_namespace (gfc_namespace * ns)
2195 gfc_charlen *cl, *cl2;
2196 gfc_namespace *p, *q;
2205 gcc_assert (ns->refs == 0);
2207 gfc_free_statements (ns->code);
2209 free_sym_tree (ns->sym_root);
2210 free_uop_tree (ns->uop_root);
2211 free_common_tree (ns->common_root);
2213 for (cl = ns->cl_list; cl; cl = cl2)
2216 gfc_free_expr (cl->length);
2220 free_st_labels (ns->st_labels);
2222 gfc_free_equiv (ns->equiv);
2224 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2225 gfc_free_interface (ns->operator[i]);
2227 gfc_free_data (ns->data);
2231 /* Recursively free any contained namespaces. */
2237 gfc_free_namespace (q);
2243 gfc_symbol_init_2 (void)
2246 gfc_current_ns = gfc_get_namespace (NULL);
2251 gfc_symbol_done_2 (void)
2254 gfc_free_namespace (gfc_current_ns);
2255 gfc_current_ns = NULL;
2259 /* Clear mark bits from symbol nodes associated with a symtree node. */
2262 clear_sym_mark (gfc_symtree * st)
2265 st->n.sym->mark = 0;
2269 /* Recursively traverse the symtree nodes. */
2272 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2278 gfc_traverse_symtree (st->left, func);
2279 gfc_traverse_symtree (st->right, func);
2284 /* Recursive namespace traversal function. */
2287 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2293 if (st->n.sym->mark == 0)
2294 (*func) (st->n.sym);
2295 st->n.sym->mark = 1;
2297 traverse_ns (st->left, func);
2298 traverse_ns (st->right, func);
2302 /* Call a given function for all symbols in the namespace. We take
2303 care that each gfc_symbol node is called exactly once. */
2306 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2309 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2311 traverse_ns (ns->sym_root, func);
2315 /* Given a symbol, mark it as SAVEd if it is allowed. */
2318 save_symbol (gfc_symbol * sym)
2321 if (sym->attr.use_assoc)
2324 if (sym->attr.in_common
2326 || sym->attr.flavor != FL_VARIABLE)
2329 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2333 /* Mark those symbols which can be SAVEd as such. */
2336 gfc_save_all (gfc_namespace * ns)
2339 gfc_traverse_ns (ns, save_symbol);
2344 /* Make sure that no changes to symbols are pending. */
2347 gfc_symbol_state(void) {
2349 if (changed_syms != NULL)
2350 gfc_internal_error("Symbol changes still pending!");
2355 /************** Global symbol handling ************/
2358 /* Search a tree for the global symbol. */
2361 gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
2367 if (strcmp (symbol->name, name) == 0)
2370 s = gfc_find_gsymbol (symbol->left, name);
2374 s = gfc_find_gsymbol (symbol->right, name);
2382 /* Compare two global symbols. Used for managing the BB tree. */
2385 gsym_compare (void * _s1, void * _s2)
2387 gfc_gsymbol *s1, *s2;
2389 s1 = (gfc_gsymbol *)_s1;
2390 s2 = (gfc_gsymbol *)_s2;
2391 return strcmp(s1->name, s2->name);
2395 /* Get a global symbol, creating it if it doesn't exist. */
2398 gfc_get_gsymbol (char *name)
2402 s = gfc_find_gsymbol (gfc_gsym_root, name);
2406 s = gfc_getmem (sizeof (gfc_gsymbol));
2407 s->type = GSYM_UNKNOWN;
2408 strcpy (s->name, name);
2410 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);