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, 51 Franklin Street, Fifth Floor, 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 if (gfc_current_ns->seen_implicit_none)
111 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
115 gfc_current_ns->seen_implicit_none = 1;
117 for (i = 0; i < GFC_LETTERS; i++)
119 gfc_clear_ts (&gfc_current_ns->default_type[i]);
120 gfc_current_ns->set_flag[i] = 1;
125 /* Reset the implicit range flags. */
128 gfc_clear_new_implicit (void)
132 for (i = 0; i < GFC_LETTERS; i++)
137 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
140 gfc_add_new_implicit_range (int c1, int c2)
147 for (i = c1; i <= c2; i++)
151 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
163 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
164 the new implicit types back into the existing types will work. */
167 gfc_merge_new_implicit (gfc_typespec * ts)
171 if (gfc_current_ns->seen_implicit_none)
173 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
177 for (i = 0; i < GFC_LETTERS; i++)
182 if (gfc_current_ns->set_flag[i])
184 gfc_error ("Letter %c already has an IMPLICIT type at %C",
188 gfc_current_ns->default_type[i] = *ts;
189 gfc_current_ns->set_flag[i] = 1;
196 /* Given a symbol, return a pointer to the typespec for its default type. */
199 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
203 letter = sym->name[0];
204 if (letter < 'a' || letter > 'z')
205 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
210 return &ns->default_type[letter - 'a'];
214 /* Given a pointer to a symbol, set its type according to the first
215 letter of its name. Fails if the letter in question has no default
219 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
223 if (sym->ts.type != BT_UNKNOWN)
224 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
226 ts = gfc_get_default_type (sym, ns);
228 if (ts->type == BT_UNKNOWN)
230 if (error_flag && !sym->attr.untyped)
232 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
233 sym->name, &sym->declared_at);
234 sym->attr.untyped = 1; /* Ensure we only give an error once. */
241 sym->attr.implicit_type = 1;
247 /******************** Symbol attribute stuff *********************/
249 /* This is a generic conflict-checker. We do this to avoid having a
250 single conflict in two places. */
252 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
253 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
256 check_conflict (symbol_attribute * attr, const char * name, locus * where)
258 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
259 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
260 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
261 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
262 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
263 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
264 *function = "FUNCTION", *subroutine = "SUBROUTINE",
265 *dimension = "DIMENSION";
270 where = &gfc_current_locus;
272 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
279 /* Check for attributes not allowed in a BLOCK DATA. */
280 if (gfc_current_state () == COMP_BLOCK_DATA)
284 if (attr->allocatable)
290 if (attr->access == ACCESS_PRIVATE)
292 if (attr->access == ACCESS_PUBLIC)
294 if (attr->intent != INTENT_UNKNOWN)
300 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
307 conf (pointer, target);
308 conf (pointer, external);
309 conf (pointer, intrinsic);
310 conf (target, external);
311 conf (target, intrinsic);
312 conf (external, dimension); /* See Fortran 95's R504. */
314 conf (external, intrinsic);
315 conf (allocatable, pointer);
316 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
317 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
318 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
319 conf (elemental, recursive);
321 conf (in_common, dummy);
322 conf (in_common, allocatable);
323 conf (in_common, result);
324 conf (dummy, result);
326 conf (in_namelist, pointer);
327 conf (in_namelist, allocatable);
329 conf (entry, result);
331 conf (function, subroutine);
333 a1 = gfc_code2string (flavors, attr->flavor);
335 if (attr->in_namelist
336 && attr->flavor != FL_VARIABLE
337 && attr->flavor != FL_UNKNOWN)
344 switch (attr->flavor)
371 if (attr->subroutine)
384 case PROC_ST_FUNCTION:
418 if (attr->intent != INTENT_UNKNOWN)
448 gfc_error ("%s attribute conflicts with %s attribute at %L",
451 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
452 a1, a2, name, where);
461 /* Mark a symbol as referenced. */
464 gfc_set_sym_referenced (gfc_symbol * sym)
466 if (sym->attr.referenced)
469 sym->attr.referenced = 1;
471 /* Remember which order dummy variables are accessed in. */
473 sym->dummy_order = next_dummy_order++;
477 /* Common subroutine called by attribute changing subroutines in order
478 to prevent them from changing a symbol that has been
479 use-associated. Returns zero if it is OK to change the symbol,
483 check_used (symbol_attribute * attr, const char * name, locus * where)
486 if (attr->use_assoc == 0)
490 where = &gfc_current_locus;
493 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
496 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
503 /* Used to prevent changing the attributes of a symbol after it has been
504 used. This check is only done for dummy variables as only these can be
505 used in specification expressions. Applying this to all symbols causes
506 an error when we reach the body of a contained function. */
509 check_done (symbol_attribute * attr, locus * where)
512 if (!(attr->dummy && attr->referenced))
516 where = &gfc_current_locus;
518 gfc_error ("Cannot change attributes of symbol at %L"
519 " after it has been used", where);
525 /* Generate an error because of a duplicate attribute. */
528 duplicate_attr (const char *attr, locus * where)
532 where = &gfc_current_locus;
534 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
539 gfc_add_allocatable (symbol_attribute * attr, locus * where)
542 if (check_used (attr, NULL, where) || check_done (attr, where))
545 if (attr->allocatable)
547 duplicate_attr ("ALLOCATABLE", where);
551 attr->allocatable = 1;
552 return check_conflict (attr, NULL, where);
557 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
560 if (check_used (attr, name, where) || check_done (attr, where))
565 duplicate_attr ("DIMENSION", where);
570 return check_conflict (attr, name, where);
575 gfc_add_external (symbol_attribute * attr, locus * where)
578 if (check_used (attr, NULL, where) || check_done (attr, where))
583 duplicate_attr ("EXTERNAL", where);
589 return check_conflict (attr, NULL, where);
594 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
597 if (check_used (attr, NULL, where) || check_done (attr, where))
602 duplicate_attr ("INTRINSIC", where);
608 return check_conflict (attr, NULL, where);
613 gfc_add_optional (symbol_attribute * attr, locus * where)
616 if (check_used (attr, NULL, where) || check_done (attr, where))
621 duplicate_attr ("OPTIONAL", where);
626 return check_conflict (attr, NULL, where);
631 gfc_add_pointer (symbol_attribute * attr, locus * where)
634 if (check_used (attr, NULL, where) || check_done (attr, where))
638 return check_conflict (attr, NULL, where);
643 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
646 if (check_used (attr, name, where) || check_done (attr, where))
650 return check_conflict (attr, name, where);
655 gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
658 if (check_used (attr, name, where))
664 ("SAVE attribute at %L cannot be specified in a PURE procedure",
671 duplicate_attr ("SAVE", where);
676 return check_conflict (attr, name, where);
681 gfc_add_target (symbol_attribute * attr, locus * where)
684 if (check_used (attr, NULL, where) || check_done (attr, where))
689 duplicate_attr ("TARGET", where);
694 return check_conflict (attr, NULL, where);
699 gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
702 if (check_used (attr, name, where))
705 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
707 return check_conflict (attr, name, where);
712 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
715 if (check_used (attr, name, where) || check_done (attr, where))
718 /* Duplicate attribute already checked for. */
720 if (check_conflict (attr, name, where) == FAILURE)
723 if (attr->flavor == FL_VARIABLE)
726 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
731 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
734 if (check_used (attr, name, where))
738 return check_conflict (attr, name, where);
743 gfc_add_in_namelist (symbol_attribute * attr, const char *name,
747 attr->in_namelist = 1;
748 return check_conflict (attr, name, where);
753 gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
756 if (check_used (attr, name, where))
760 return check_conflict (attr, name, where);
765 gfc_add_elemental (symbol_attribute * attr, locus * where)
768 if (check_used (attr, NULL, where) || check_done (attr, where))
772 return check_conflict (attr, NULL, where);
777 gfc_add_pure (symbol_attribute * attr, locus * where)
780 if (check_used (attr, NULL, where) || check_done (attr, where))
784 return check_conflict (attr, NULL, where);
789 gfc_add_recursive (symbol_attribute * attr, locus * where)
792 if (check_used (attr, NULL, where) || check_done (attr, where))
796 return check_conflict (attr, NULL, where);
801 gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
804 if (check_used (attr, name, where))
809 duplicate_attr ("ENTRY", where);
814 return check_conflict (attr, name, where);
819 gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
822 if (attr->flavor != FL_PROCEDURE
823 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
827 return check_conflict (attr, name, where);
832 gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
835 if (attr->flavor != FL_PROCEDURE
836 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
839 attr->subroutine = 1;
840 return check_conflict (attr, name, where);
845 gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
848 if (attr->flavor != FL_PROCEDURE
849 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
853 return check_conflict (attr, name, where);
857 /* Flavors are special because some flavors are not what Fortran
858 considers attributes and can be reaffirmed multiple times. */
861 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
865 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
866 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
867 || f == FL_NAMELIST) && check_used (attr, name, where))
870 if (attr->flavor == f && f == FL_VARIABLE)
873 if (attr->flavor != FL_UNKNOWN)
876 where = &gfc_current_locus;
878 gfc_error ("%s attribute conflicts with %s attribute at %L",
879 gfc_code2string (flavors, attr->flavor),
880 gfc_code2string (flavors, f), where);
887 return check_conflict (attr, name, where);
892 gfc_add_procedure (symbol_attribute * attr, procedure_type t,
893 const char *name, locus * where)
896 if (check_used (attr, name, where) || check_done (attr, where))
899 if (attr->flavor != FL_PROCEDURE
900 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
904 where = &gfc_current_locus;
906 if (attr->proc != PROC_UNKNOWN)
908 gfc_error ("%s procedure at %L is already %s %s procedure",
909 gfc_code2string (procedures, t), where,
910 gfc_article (gfc_code2string (procedures, attr->proc)),
911 gfc_code2string (procedures, attr->proc));
918 /* Statement functions are always scalar and functions. */
919 if (t == PROC_ST_FUNCTION
920 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
924 return check_conflict (attr, name, where);
929 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
932 if (check_used (attr, NULL, where))
935 if (attr->intent == INTENT_UNKNOWN)
937 attr->intent = intent;
938 return check_conflict (attr, NULL, where);
942 where = &gfc_current_locus;
944 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
945 gfc_intent_string (attr->intent),
946 gfc_intent_string (intent), where);
952 /* No checks for use-association in public and private statements. */
955 gfc_add_access (symbol_attribute * attr, gfc_access access,
956 const char *name, locus * where)
959 if (attr->access == ACCESS_UNKNOWN)
961 attr->access = access;
962 return check_conflict (attr, name, where);
966 where = &gfc_current_locus;
967 gfc_error ("ACCESS specification at %L was already specified", where);
974 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
975 gfc_formal_arglist * formal, locus * where)
978 if (check_used (&sym->attr, sym->name, where))
982 where = &gfc_current_locus;
984 if (sym->attr.if_source != IFSRC_UNKNOWN
985 && sym->attr.if_source != IFSRC_DECL)
987 gfc_error ("Symbol '%s' at %L already has an explicit interface",
992 sym->formal = formal;
993 sym->attr.if_source = source;
999 /* Add a type to a symbol. */
1002 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
1006 /* TODO: This is legal if it is reaffirming an implicit type.
1007 if (check_done (&sym->attr, where))
1011 where = &gfc_current_locus;
1013 if (sym->ts.type != BT_UNKNOWN)
1015 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1016 where, gfc_basic_typename (sym->ts.type));
1020 flavor = sym->attr.flavor;
1022 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1023 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1024 && sym->attr.subroutine)
1025 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1027 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1036 /* Clears all attributes. */
1039 gfc_clear_attr (symbol_attribute * attr)
1041 memset (attr, 0, sizeof(symbol_attribute));
1045 /* Check for missing attributes in the new symbol. Currently does
1046 nothing, but it's not clear that it is unnecessary yet. */
1049 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1050 locus * where ATTRIBUTE_UNUSED)
1057 /* Copy an attribute to a symbol attribute, bit by bit. Some
1058 attributes have a lot of side-effects but cannot be present given
1059 where we are called from, so we ignore some bits. */
1062 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1065 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1068 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1070 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1072 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1074 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1076 if (src->target && gfc_add_target (dest, where) == FAILURE)
1078 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1080 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1085 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1088 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1091 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1093 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1095 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1098 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1100 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1102 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1104 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1107 if (src->flavor != FL_UNKNOWN
1108 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1111 if (src->intent != INTENT_UNKNOWN
1112 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1115 if (src->access != ACCESS_UNKNOWN
1116 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1119 if (gfc_missing_attr (dest, where) == FAILURE)
1122 /* The subroutines that set these bits also cause flavors to be set,
1123 and that has already happened in the original, so don't let it
1128 dest->intrinsic = 1;
1137 /************** Component name management ************/
1139 /* Component names of a derived type form their own little namespaces
1140 that are separate from all other spaces. The space is composed of
1141 a singly linked list of gfc_component structures whose head is
1142 located in the parent symbol. */
1145 /* Add a component name to a symbol. The call fails if the name is
1146 already present. On success, the component pointer is modified to
1147 point to the additional component structure. */
1150 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1152 gfc_component *p, *tail;
1156 for (p = sym->components; p; p = p->next)
1158 if (strcmp (p->name, name) == 0)
1160 gfc_error ("Component '%s' at %C already declared at %L",
1168 /* Allocate a new component. */
1169 p = gfc_get_component ();
1172 sym->components = p;
1176 p->name = gfc_get_string (name);
1177 p->loc = gfc_current_locus;
1184 /* Recursive function to switch derived types of all symbol in a
1188 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1196 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1197 sym->ts.derived = to;
1199 switch_types (st->left, from, to);
1200 switch_types (st->right, from, to);
1204 /* This subroutine is called when a derived type is used in order to
1205 make the final determination about which version to use. The
1206 standard requires that a type be defined before it is 'used', but
1207 such types can appear in IMPLICIT statements before the actual
1208 definition. 'Using' in this context means declaring a variable to
1209 be that type or using the type constructor.
1211 If a type is used and the components haven't been defined, then we
1212 have to have a derived type in a parent unit. We find the node in
1213 the other namespace and point the symtree node in this namespace to
1214 that node. Further reference to this name point to the correct
1215 node. If we can't find the node in a parent namespace, then we have
1218 This subroutine takes a pointer to a symbol node and returns a
1219 pointer to the translated node or NULL for an error. Usually there
1220 is no translation and we return the node we were passed. */
1223 gfc_use_derived (gfc_symbol * sym)
1230 if (sym->components != NULL)
1231 return sym; /* Already defined. */
1233 if (sym->ns->parent == NULL)
1236 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1238 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1242 if (s == NULL || s->attr.flavor != FL_DERIVED)
1245 /* Get rid of symbol sym, translating all references to s. */
1246 for (i = 0; i < GFC_LETTERS; i++)
1248 t = &sym->ns->default_type[i];
1249 if (t->derived == sym)
1253 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1258 /* Unlink from list of modified symbols. */
1259 if (changed_syms == sym)
1260 changed_syms = sym->tlink;
1262 for (p = changed_syms; p; p = p->tlink)
1263 if (p->tlink == sym)
1265 p->tlink = sym->tlink;
1269 switch_types (sym->ns->sym_root, sym, s);
1271 /* TODO: Also have to replace sym -> s in other lists like
1272 namelists, common lists and interface lists. */
1273 gfc_free_symbol (sym);
1278 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1284 /* Given a derived type node and a component name, try to locate the
1285 component structure. Returns the NULL pointer if the component is
1286 not found or the components are private. */
1289 gfc_find_component (gfc_symbol * sym, const char *name)
1296 sym = gfc_use_derived (sym);
1301 for (p = sym->components; p; p = p->next)
1302 if (strcmp (p->name, name) == 0)
1306 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1310 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1312 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1322 /* Given a symbol, free all of the component structures and everything
1326 free_components (gfc_component * p)
1334 gfc_free_array_spec (p->as);
1335 gfc_free_expr (p->initializer);
1342 /* Set component attributes from a standard symbol attribute
1346 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1349 c->dimension = attr->dimension;
1350 c->pointer = attr->pointer;
1354 /* Get a standard symbol attribute structure given the component
1358 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1361 gfc_clear_attr (attr);
1362 attr->dimension = c->dimension;
1363 attr->pointer = c->pointer;
1367 /******************** Statement label management ********************/
1369 /* Free a single gfc_st_label structure, making sure the list is not
1370 messed up. This function is called only when some parse error
1374 gfc_free_st_label (gfc_st_label * l)
1381 (l->prev->next = l->next);
1384 (l->next->prev = l->prev);
1386 if (l->format != NULL)
1387 gfc_free_expr (l->format);
1391 /* Free a whole list of gfc_st_label structures. */
1394 free_st_labels (gfc_st_label * l1)
1401 if (l1->format != NULL)
1402 gfc_free_expr (l1->format);
1408 /* Given a label number, search for and return a pointer to the label
1409 structure, creating it if it does not exist. */
1412 gfc_get_st_label (int labelno)
1416 /* First see if the label is already in this namespace. */
1417 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1418 if (lp->value == labelno)
1423 lp = gfc_getmem (sizeof (gfc_st_label));
1425 lp->value = labelno;
1426 lp->defined = ST_LABEL_UNKNOWN;
1427 lp->referenced = ST_LABEL_UNKNOWN;
1430 lp->next = gfc_current_ns->st_labels;
1431 if (gfc_current_ns->st_labels)
1432 gfc_current_ns->st_labels->prev = lp;
1433 gfc_current_ns->st_labels = lp;
1439 /* Called when a statement with a statement label is about to be
1440 accepted. We add the label to the list of the current namespace,
1441 making sure it hasn't been defined previously and referenced
1445 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1449 labelno = lp->value;
1451 if (lp->defined != ST_LABEL_UNKNOWN)
1452 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1453 &lp->where, label_locus);
1456 lp->where = *label_locus;
1460 case ST_LABEL_FORMAT:
1461 if (lp->referenced == ST_LABEL_TARGET)
1462 gfc_error ("Label %d at %C already referenced as branch target",
1465 lp->defined = ST_LABEL_FORMAT;
1469 case ST_LABEL_TARGET:
1470 if (lp->referenced == ST_LABEL_FORMAT)
1471 gfc_error ("Label %d at %C already referenced as a format label",
1474 lp->defined = ST_LABEL_TARGET;
1479 lp->defined = ST_LABEL_BAD_TARGET;
1480 lp->referenced = ST_LABEL_BAD_TARGET;
1486 /* Reference a label. Given a label and its type, see if that
1487 reference is consistent with what is known about that label,
1488 updating the unknown state. Returns FAILURE if something goes
1492 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1494 gfc_sl_type label_type;
1501 labelno = lp->value;
1503 if (lp->defined != ST_LABEL_UNKNOWN)
1504 label_type = lp->defined;
1507 label_type = lp->referenced;
1508 lp->where = gfc_current_locus;
1511 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1513 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1518 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1519 && type == ST_LABEL_FORMAT)
1521 gfc_error ("Label %d at %C previously used as branch target", labelno);
1526 lp->referenced = type;
1534 /************** Symbol table management subroutines ****************/
1536 /* Basic details: Fortran 95 requires a potentially unlimited number
1537 of distinct namespaces when compiling a program unit. This case
1538 occurs during a compilation of internal subprograms because all of
1539 the internal subprograms must be read before we can start
1540 generating code for the host.
1542 Given the tricky nature of the Fortran grammar, we must be able to
1543 undo changes made to a symbol table if the current interpretation
1544 of a statement is found to be incorrect. Whenever a symbol is
1545 looked up, we make a copy of it and link to it. All of these
1546 symbols are kept in a singly linked list so that we can commit or
1547 undo the changes at a later time.
1549 A symtree may point to a symbol node outside of its namespace. In
1550 this case, that symbol has been used as a host associated variable
1551 at some previous time. */
1553 /* Allocate a new namespace structure. Copies the implicit types from
1554 PARENT if PARENT_TYPES is set. */
1557 gfc_get_namespace (gfc_namespace * parent, int parent_types)
1561 gfc_intrinsic_op in;
1564 ns = gfc_getmem (sizeof (gfc_namespace));
1565 ns->sym_root = NULL;
1566 ns->uop_root = NULL;
1567 ns->default_access = ACCESS_UNKNOWN;
1568 ns->parent = parent;
1570 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1571 ns->operator_access[in] = ACCESS_UNKNOWN;
1573 /* Initialize default implicit types. */
1574 for (i = 'a'; i <= 'z'; i++)
1576 ns->set_flag[i - 'a'] = 0;
1577 ts = &ns->default_type[i - 'a'];
1579 if (parent_types && ns->parent != NULL)
1581 /* Copy parent settings */
1582 *ts = ns->parent->default_type[i - 'a'];
1586 if (gfc_option.flag_implicit_none != 0)
1592 if ('i' <= i && i <= 'n')
1594 ts->type = BT_INTEGER;
1595 ts->kind = gfc_default_integer_kind;
1600 ts->kind = gfc_default_real_kind;
1610 /* Comparison function for symtree nodes. */
1613 compare_symtree (void * _st1, void * _st2)
1615 gfc_symtree *st1, *st2;
1617 st1 = (gfc_symtree *) _st1;
1618 st2 = (gfc_symtree *) _st2;
1620 return strcmp (st1->name, st2->name);
1624 /* Allocate a new symtree node and associate it with the new symbol. */
1627 gfc_new_symtree (gfc_symtree ** root, const char *name)
1631 st = gfc_getmem (sizeof (gfc_symtree));
1632 st->name = gfc_get_string (name);
1634 gfc_insert_bbt (root, st, compare_symtree);
1639 /* Delete a symbol from the tree. Does not free the symbol itself! */
1642 delete_symtree (gfc_symtree ** root, const char *name)
1644 gfc_symtree st, *st0;
1646 st0 = gfc_find_symtree (*root, name);
1648 st.name = gfc_get_string (name);
1649 gfc_delete_bbt (root, &st, compare_symtree);
1655 /* Given a root symtree node and a name, try to find the symbol within
1656 the namespace. Returns NULL if the symbol is not found. */
1659 gfc_find_symtree (gfc_symtree * st, const char *name)
1665 c = strcmp (name, st->name);
1669 st = (c < 0) ? st->left : st->right;
1676 /* Given a name find a user operator node, creating it if it doesn't
1677 exist. These are much simpler than symbols because they can't be
1678 ambiguous with one another. */
1681 gfc_get_uop (const char *name)
1686 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1690 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1692 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1693 uop->name = gfc_get_string (name);
1694 uop->access = ACCESS_UNKNOWN;
1695 uop->ns = gfc_current_ns;
1701 /* Given a name find the user operator node. Returns NULL if it does
1705 gfc_find_uop (const char *name, gfc_namespace * ns)
1710 ns = gfc_current_ns;
1712 st = gfc_find_symtree (ns->uop_root, name);
1713 return (st == NULL) ? NULL : st->n.uop;
1717 /* Remove a gfc_symbol structure and everything it points to. */
1720 gfc_free_symbol (gfc_symbol * sym)
1726 gfc_free_array_spec (sym->as);
1728 free_components (sym->components);
1730 gfc_free_expr (sym->value);
1732 gfc_free_namelist (sym->namelist);
1734 gfc_free_namespace (sym->formal_ns);
1736 gfc_free_interface (sym->generic);
1738 gfc_free_formal_arglist (sym->formal);
1744 /* Allocate and initialize a new symbol node. */
1747 gfc_new_symbol (const char *name, gfc_namespace * ns)
1751 p = gfc_getmem (sizeof (gfc_symbol));
1753 gfc_clear_ts (&p->ts);
1754 gfc_clear_attr (&p->attr);
1757 p->declared_at = gfc_current_locus;
1759 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1760 gfc_internal_error ("new_symbol(): Symbol name too long");
1762 p->name = gfc_get_string (name);
1767 /* Generate an error if a symbol is ambiguous. */
1770 ambiguous_symbol (const char *name, gfc_symtree * st)
1773 if (st->n.sym->module)
1774 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1775 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1777 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1778 "from current program unit", name, st->n.sym->name);
1782 /* Search for a symtree starting in the current namespace, resorting to
1783 any parent namespaces if requested by a nonzero parent_flag.
1784 Returns nonzero if the name is ambiguous. */
1787 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1788 gfc_symtree ** result)
1793 ns = gfc_current_ns;
1797 st = gfc_find_symtree (ns->sym_root, name);
1803 ambiguous_symbol (name, st);
1822 /* Same, but returns the symbol instead. */
1825 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1826 gfc_symbol ** result)
1831 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1836 *result = st->n.sym;
1842 /* Save symbol with the information necessary to back it out. */
1845 save_symbol_data (gfc_symbol * sym)
1848 if (sym->new || sym->old_symbol != NULL)
1851 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1852 *(sym->old_symbol) = *sym;
1854 sym->tlink = changed_syms;
1859 /* Given a name, find a symbol, or create it if it does not exist yet
1860 in the current namespace. If the symbol is found we make sure that
1863 The integer return code indicates
1865 1 The symbol name was ambiguous
1866 2 The name meant to be established was already host associated.
1868 So if the return value is nonzero, then an error was issued. */
1871 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1876 /* This doesn't usually happen during resolution. */
1878 ns = gfc_current_ns;
1880 /* Try to find the symbol in ns. */
1881 st = gfc_find_symtree (ns->sym_root, name);
1885 /* If not there, create a new symbol. */
1886 p = gfc_new_symbol (name, ns);
1888 /* Add to the list of tentative symbols. */
1889 p->old_symbol = NULL;
1890 p->tlink = changed_syms;
1895 st = gfc_new_symtree (&ns->sym_root, name);
1902 /* Make sure the existing symbol is OK. */
1905 ambiguous_symbol (name, st);
1911 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1913 /* Symbol is from another namespace. */
1914 gfc_error ("Symbol '%s' at %C has already been host associated",
1921 /* Copy in case this symbol is changed. */
1922 save_symbol_data (p);
1931 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1937 i = gfc_get_sym_tree (name, ns, &st);
1942 *result = st->n.sym;
1949 /* Subroutine that searches for a symbol, creating it if it doesn't
1950 exist, but tries to host-associate the symbol if possible. */
1953 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1958 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1961 save_symbol_data (st->n.sym);
1967 if (gfc_current_ns->parent != NULL)
1969 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1980 return gfc_get_sym_tree (name, gfc_current_ns, result);
1985 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
1990 i = gfc_get_ha_sym_tree (name, &st);
1993 *result = st->n.sym;
2000 /* Return true if both symbols could refer to the same data object. Does
2001 not take account of aliasing due to equivalence statements. */
2004 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
2006 /* Aliasing isn't possible if the symbols have different base types. */
2007 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2010 /* Pointers can point to other pointers, target objects and allocatable
2011 objects. Two allocatable objects cannot share the same storage. */
2012 if (lsym->attr.pointer
2013 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2015 if (lsym->attr.target && rsym->attr.pointer)
2017 if (lsym->attr.allocatable && rsym->attr.pointer)
2024 /* Undoes all the changes made to symbols in the current statement.
2025 This subroutine is made simpler due to the fact that attributes are
2026 never removed once added. */
2029 gfc_undo_symbols (void)
2031 gfc_symbol *p, *q, *old;
2033 for (p = changed_syms; p; p = q)
2039 /* Symbol was new. */
2040 delete_symtree (&p->ns->sym_root, p->name);
2044 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2046 gfc_free_symbol (p);
2050 /* Restore previous state of symbol. Just copy simple stuff. */
2052 old = p->old_symbol;
2054 p->ts.type = old->ts.type;
2055 p->ts.kind = old->ts.kind;
2057 p->attr = old->attr;
2059 if (p->value != old->value)
2061 gfc_free_expr (old->value);
2065 if (p->as != old->as)
2068 gfc_free_array_spec (p->as);
2072 p->generic = old->generic;
2073 p->component_access = old->component_access;
2075 if (p->namelist != NULL && old->namelist == NULL)
2077 gfc_free_namelist (p->namelist);
2083 if (p->namelist_tail != old->namelist_tail)
2085 gfc_free_namelist (old->namelist_tail);
2086 old->namelist_tail->next = NULL;
2090 p->namelist_tail = old->namelist_tail;
2092 if (p->formal != old->formal)
2094 gfc_free_formal_arglist (p->formal);
2095 p->formal = old->formal;
2098 gfc_free (p->old_symbol);
2099 p->old_symbol = NULL;
2103 changed_syms = NULL;
2107 /* Makes the changes made in the current statement permanent-- gets
2108 rid of undo information. */
2111 gfc_commit_symbols (void)
2115 for (p = changed_syms; p; p = q)
2122 if (p->old_symbol != NULL)
2124 gfc_free (p->old_symbol);
2125 p->old_symbol = NULL;
2129 changed_syms = NULL;
2133 /* Recursive function that deletes an entire tree and all the common
2134 head structures it points to. */
2137 free_common_tree (gfc_symtree * common_tree)
2139 if (common_tree == NULL)
2142 free_common_tree (common_tree->left);
2143 free_common_tree (common_tree->right);
2145 gfc_free (common_tree);
2149 /* Recursive function that deletes an entire tree and all the user
2150 operator nodes that it contains. */
2153 free_uop_tree (gfc_symtree * uop_tree)
2156 if (uop_tree == NULL)
2159 free_uop_tree (uop_tree->left);
2160 free_uop_tree (uop_tree->right);
2162 gfc_free_interface (uop_tree->n.uop->operator);
2164 gfc_free (uop_tree->n.uop);
2165 gfc_free (uop_tree);
2169 /* Recursive function that deletes an entire tree and all the symbols
2170 that it contains. */
2173 free_sym_tree (gfc_symtree * sym_tree)
2178 if (sym_tree == NULL)
2181 free_sym_tree (sym_tree->left);
2182 free_sym_tree (sym_tree->right);
2184 sym = sym_tree->n.sym;
2188 gfc_internal_error ("free_sym_tree(): Negative refs");
2190 if (sym->formal_ns != NULL && sym->refs == 1)
2192 /* As formal_ns contains a reference to sym, delete formal_ns just
2193 before the deletion of sym. */
2194 ns = sym->formal_ns;
2195 sym->formal_ns = NULL;
2196 gfc_free_namespace (ns);
2198 else if (sym->refs == 0)
2200 /* Go ahead and delete the symbol. */
2201 gfc_free_symbol (sym);
2204 gfc_free (sym_tree);
2208 /* Free a namespace structure and everything below it. Interface
2209 lists associated with intrinsic operators are not freed. These are
2210 taken care of when a specific name is freed. */
2213 gfc_free_namespace (gfc_namespace * ns)
2215 gfc_charlen *cl, *cl2;
2216 gfc_namespace *p, *q;
2225 gcc_assert (ns->refs == 0);
2227 gfc_free_statements (ns->code);
2229 free_sym_tree (ns->sym_root);
2230 free_uop_tree (ns->uop_root);
2231 free_common_tree (ns->common_root);
2233 for (cl = ns->cl_list; cl; cl = cl2)
2236 gfc_free_expr (cl->length);
2240 free_st_labels (ns->st_labels);
2242 gfc_free_equiv (ns->equiv);
2244 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2245 gfc_free_interface (ns->operator[i]);
2247 gfc_free_data (ns->data);
2251 /* Recursively free any contained namespaces. */
2257 gfc_free_namespace (q);
2263 gfc_symbol_init_2 (void)
2266 gfc_current_ns = gfc_get_namespace (NULL, 0);
2271 gfc_symbol_done_2 (void)
2274 gfc_free_namespace (gfc_current_ns);
2275 gfc_current_ns = NULL;
2279 /* Clear mark bits from symbol nodes associated with a symtree node. */
2282 clear_sym_mark (gfc_symtree * st)
2285 st->n.sym->mark = 0;
2289 /* Recursively traverse the symtree nodes. */
2292 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2298 gfc_traverse_symtree (st->left, func);
2299 gfc_traverse_symtree (st->right, func);
2304 /* Recursive namespace traversal function. */
2307 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2313 if (st->n.sym->mark == 0)
2314 (*func) (st->n.sym);
2315 st->n.sym->mark = 1;
2317 traverse_ns (st->left, func);
2318 traverse_ns (st->right, func);
2322 /* Call a given function for all symbols in the namespace. We take
2323 care that each gfc_symbol node is called exactly once. */
2326 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2329 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2331 traverse_ns (ns->sym_root, func);
2335 /* Return TRUE if the symbol is an automatic variable. */
2337 gfc_is_var_automatic (gfc_symbol * sym)
2339 /* Pointer and allocatable variables are never automatic. */
2340 if (sym->attr.pointer || sym->attr.allocatable)
2342 /* Check for arrays with non-constant size. */
2343 if (sym->attr.dimension && sym->as
2344 && !gfc_is_compile_time_shape (sym->as))
2346 /* Check for non-constant length character variables. */
2347 if (sym->ts.type == BT_CHARACTER
2349 && gfc_is_constant_expr (sym->ts.cl->length))
2354 /* Given a symbol, mark it as SAVEd if it is allowed. */
2357 save_symbol (gfc_symbol * sym)
2360 if (sym->attr.use_assoc)
2363 if (sym->attr.in_common
2365 || sym->attr.flavor != FL_VARIABLE)
2367 /* Automatic objects are not saved. */
2368 if (gfc_is_var_automatic (sym))
2370 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2374 /* Mark those symbols which can be SAVEd as such. */
2377 gfc_save_all (gfc_namespace * ns)
2380 gfc_traverse_ns (ns, save_symbol);
2385 /* Make sure that no changes to symbols are pending. */
2388 gfc_symbol_state(void) {
2390 if (changed_syms != NULL)
2391 gfc_internal_error("Symbol changes still pending!");
2396 /************** Global symbol handling ************/
2399 /* Search a tree for the global symbol. */
2402 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
2408 if (strcmp (symbol->name, name) == 0)
2411 s = gfc_find_gsymbol (symbol->left, name);
2415 s = gfc_find_gsymbol (symbol->right, name);
2423 /* Compare two global symbols. Used for managing the BB tree. */
2426 gsym_compare (void * _s1, void * _s2)
2428 gfc_gsymbol *s1, *s2;
2430 s1 = (gfc_gsymbol *)_s1;
2431 s2 = (gfc_gsymbol *)_s2;
2432 return strcmp(s1->name, s2->name);
2436 /* Get a global symbol, creating it if it doesn't exist. */
2439 gfc_get_gsymbol (const char *name)
2443 s = gfc_find_gsymbol (gfc_gsym_root, name);
2447 s = gfc_getmem (sizeof (gfc_gsymbol));
2448 s->type = GSYM_UNKNOWN;
2449 s->name = gfc_get_string (name);
2451 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);