1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 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
32 /* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
36 const mstring flavors[] =
38 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
46 const mstring procedures[] =
48 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
49 minit ("MODULE-PROC", PROC_MODULE),
50 minit ("INTERNAL-PROC", PROC_INTERNAL),
51 minit ("DUMMY-PROC", PROC_DUMMY),
52 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
53 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
54 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
58 const mstring intents[] =
60 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
61 minit ("IN", INTENT_IN),
62 minit ("OUT", INTENT_OUT),
63 minit ("INOUT", INTENT_INOUT),
67 const mstring access_types[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70 minit ("PUBLIC", ACCESS_PUBLIC),
71 minit ("PRIVATE", ACCESS_PRIVATE),
75 const mstring ifsrc_types[] =
77 minit ("UNKNOWN", IFSRC_UNKNOWN),
78 minit ("DECL", IFSRC_DECL),
79 minit ("BODY", IFSRC_IFBODY),
80 minit ("USAGE", IFSRC_USAGE)
84 /* This is to make sure the backend generates setup code in the correct
87 static int next_dummy_order = 1;
90 gfc_namespace *gfc_current_ns;
92 gfc_gsymbol *gfc_gsym_root = NULL;
94 static gfc_symbol *changed_syms = NULL;
97 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
99 /* The following static variables hold the default types set by
100 IMPLICIT statements. We have to store kind information because of
101 IMPLICIT DOUBLE PRECISION statements. IMPLICIT NONE stores a
102 BT_UNKNOWN into all elements. The arrays of flags indicate whether
103 a particular element has been explicitly set or not. */
105 static gfc_typespec new_ts[GFC_LETTERS];
106 static int new_flag[GFC_LETTERS];
109 /* Handle a correctly parsed IMPLICIT NONE. */
112 gfc_set_implicit_none (void)
116 for (i = 'a'; i <= 'z'; i++)
118 gfc_clear_ts (&gfc_current_ns->default_type[i - 'a']);
119 gfc_current_ns->set_flag[i - 'a'] = 1;
124 /* Sets the implicit types parsed by gfc_match_implicit(). */
127 gfc_set_implicit (void)
131 for (i = 0; i < GFC_LETTERS; i++)
134 gfc_current_ns->default_type[i] = new_ts[i];
135 gfc_current_ns->set_flag[i] = 1;
140 /* Wipe anything a previous IMPLICIT statement may have tried to do. */
141 void gfc_clear_new_implicit (void)
145 for (i = 0; i < GFC_LETTERS; i++)
147 gfc_clear_ts (&new_ts[i]);
154 /* Prepare for a new implicit range. Sets flags in new_flag[] and
155 copies the typespec to new_ts[]. */
157 try gfc_add_new_implicit_range (int c1, int c2, gfc_typespec * ts)
164 for (i = c1; i <= c2; i++)
168 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
181 /* Add a matched implicit range for gfc_set_implicit(). An implicit
182 statement has been fully matched at this point. We now need to
183 check if merging the new implicit types back into the existing
187 gfc_merge_new_implicit (void)
191 for (i = 0; i < GFC_LETTERS; i++)
194 if (gfc_current_ns->set_flag[i])
196 gfc_error ("Letter %c already has an IMPLICIT type at %C",
206 /* Given a symbol, return a pointer to the typespec for it's default
210 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
214 letter = sym->name[0];
215 if (letter < 'a' || letter > 'z')
216 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
221 return &ns->default_type[letter - 'a'];
225 /* Given a pointer to a symbol, set its type according to the first
226 letter of its name. Fails if the letter in question has no default
230 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
234 if (sym->ts.type != BT_UNKNOWN)
235 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
237 ts = gfc_get_default_type (sym, ns);
239 if (ts->type == BT_UNKNOWN)
242 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
249 sym->attr.implicit_type = 1;
255 /******************** Symbol attribute stuff *********************/
257 /* This is a generic conflict-checker. We do this to avoid having a
258 single conflict in two places. */
260 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
261 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
264 check_conflict (symbol_attribute * attr, locus * where)
266 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
267 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
268 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
269 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
270 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
271 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
272 *function = "FUNCTION", *subroutine = "SUBROUTINE",
273 *dimension = "DIMENSION";
278 where = &gfc_current_locus;
280 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
287 /* Check for attributes not allowed in a BLOCK DATA. */
288 if (gfc_current_state () == COMP_BLOCK_DATA)
292 if (attr->allocatable)
298 if (attr->access == ACCESS_PRIVATE)
300 if (attr->access == ACCESS_PUBLIC)
302 if (attr->intent != INTENT_UNKNOWN)
308 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
315 conf (pointer, target);
316 conf (pointer, external);
317 conf (pointer, intrinsic);
318 conf (target, external);
319 conf (target, intrinsic);
320 conf (external, dimension); /* See Fortran 95's R504. */
322 conf (external, intrinsic);
323 conf (allocatable, pointer);
324 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
325 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
326 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
327 conf (elemental, recursive);
329 conf (in_common, dummy);
330 conf (in_common, allocatable);
331 conf (in_common, result);
332 conf (dummy, result);
334 conf (in_namelist, pointer);
335 conf (in_namelist, allocatable);
337 conf (entry, result);
339 conf (function, subroutine);
341 a1 = gfc_code2string (flavors, attr->flavor);
343 if (attr->in_namelist
344 && attr->flavor != FL_VARIABLE
345 && attr->flavor != FL_UNKNOWN)
352 switch (attr->flavor)
379 if (attr->subroutine)
392 case PROC_ST_FUNCTION:
425 if (attr->intent != INTENT_UNKNOWN)
453 gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, 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, locus * where)
486 if (attr->use_assoc == 0)
490 where = &gfc_current_locus;
492 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
499 /* Used to prevent changing the attributes of a symbol after it has been
500 used. This check is only done from dummy variable as only these can be
501 used in specification expressions. Applying this to all symbols causes
502 error when we reach the body of a contained function. */
505 check_done (symbol_attribute * attr, locus * where)
508 if (!(attr->dummy && attr->referenced))
512 where = &gfc_current_locus;
514 gfc_error ("Cannot change attributes of symbol at %L"
515 " after it has been used", where);
521 /* Generate an error because of a duplicate attribute. */
524 duplicate_attr (const char *attr, locus * where)
528 where = &gfc_current_locus;
530 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
535 gfc_add_allocatable (symbol_attribute * attr, locus * where)
538 if (check_used (attr, where) || check_done (attr, where))
541 if (attr->allocatable)
543 duplicate_attr ("ALLOCATABLE", where);
547 attr->allocatable = 1;
548 return check_conflict (attr, where);
553 gfc_add_dimension (symbol_attribute * attr, locus * where)
556 if (check_used (attr, where) || check_done (attr, where))
561 duplicate_attr ("DIMENSION", where);
566 return check_conflict (attr, where);
571 gfc_add_external (symbol_attribute * attr, locus * where)
574 if (check_used (attr, where) || check_done (attr, where))
579 duplicate_attr ("EXTERNAL", where);
585 return check_conflict (attr, where);
590 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
593 if (check_used (attr, where) || check_done (attr, where))
598 duplicate_attr ("INTRINSIC", where);
604 return check_conflict (attr, where);
609 gfc_add_optional (symbol_attribute * attr, locus * where)
612 if (check_used (attr, where) || check_done (attr, where))
617 duplicate_attr ("OPTIONAL", where);
622 return check_conflict (attr, where);
627 gfc_add_pointer (symbol_attribute * attr, locus * where)
630 if (check_used (attr, where) || check_done (attr, where))
634 return check_conflict (attr, where);
639 gfc_add_result (symbol_attribute * attr, locus * where)
642 if (check_used (attr, where) || check_done (attr, where))
646 return check_conflict (attr, where);
651 gfc_add_save (symbol_attribute * attr, locus * where)
654 if (check_used (attr, where))
660 ("SAVE attribute at %L cannot be specified in a PURE procedure",
667 duplicate_attr ("SAVE", where);
672 return check_conflict (attr, where);
677 gfc_add_target (symbol_attribute * attr, locus * where)
680 if (check_used (attr, where) || check_done (attr, where))
685 duplicate_attr ("TARGET", where);
690 return check_conflict (attr, where);
695 gfc_add_dummy (symbol_attribute * attr, locus * where)
698 if (check_used (attr, where))
701 /* Duplicate dummy arguments are allow due to ENTRY statements. */
703 return check_conflict (attr, where);
708 gfc_add_in_common (symbol_attribute * attr, locus * where)
711 if (check_used (attr, where) || check_done (attr, where))
714 /* Duplicate attribute already checked for. */
716 if (check_conflict (attr, where) == FAILURE)
719 if (attr->flavor == FL_VARIABLE)
722 return gfc_add_flavor (attr, FL_VARIABLE, where);
727 gfc_add_data (symbol_attribute *attr, locus *where)
730 if (check_used (attr, where))
734 return check_conflict (attr, where);
739 gfc_add_in_namelist (symbol_attribute * attr, locus * where)
742 attr->in_namelist = 1;
743 return check_conflict (attr, where);
748 gfc_add_sequence (symbol_attribute * attr, locus * where)
751 if (check_used (attr, where))
755 return check_conflict (attr, where);
760 gfc_add_elemental (symbol_attribute * attr, locus * where)
763 if (check_used (attr, where) || check_done (attr, where))
767 return check_conflict (attr, where);
772 gfc_add_pure (symbol_attribute * attr, locus * where)
775 if (check_used (attr, where) || check_done (attr, where))
779 return check_conflict (attr, where);
784 gfc_add_recursive (symbol_attribute * attr, locus * where)
787 if (check_used (attr, where) || check_done (attr, where))
791 return check_conflict (attr, where);
796 gfc_add_entry (symbol_attribute * attr, locus * where)
799 if (check_used (attr, where))
804 duplicate_attr ("ENTRY", where);
809 return check_conflict (attr, where);
814 gfc_add_function (symbol_attribute * attr, locus * where)
817 if (attr->flavor != FL_PROCEDURE
818 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
822 return check_conflict (attr, where);
827 gfc_add_subroutine (symbol_attribute * attr, locus * where)
830 if (attr->flavor != FL_PROCEDURE
831 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
834 attr->subroutine = 1;
835 return check_conflict (attr, where);
840 gfc_add_generic (symbol_attribute * attr, locus * where)
843 if (attr->flavor != FL_PROCEDURE
844 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
848 return check_conflict (attr, where);
852 /* Flavors are special because some flavors are not what fortran
853 considers attributes and can be reaffirmed multiple times. */
856 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
859 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
860 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
861 || f == FL_NAMELIST) && check_used (attr, where))
864 if (attr->flavor == f && f == FL_VARIABLE)
867 if (attr->flavor != FL_UNKNOWN)
870 where = &gfc_current_locus;
872 gfc_error ("%s attribute conflicts with %s attribute at %L",
873 gfc_code2string (flavors, attr->flavor),
874 gfc_code2string (flavors, f), where);
881 return check_conflict (attr, where);
886 gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
889 if (check_used (attr, where) || check_done (attr, where))
892 if (attr->flavor != FL_PROCEDURE
893 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
897 where = &gfc_current_locus;
899 if (attr->proc != PROC_UNKNOWN)
901 gfc_error ("%s procedure at %L is already %s %s procedure",
902 gfc_code2string (procedures, t), where,
903 gfc_article (gfc_code2string (procedures, attr->proc)),
904 gfc_code2string (procedures, attr->proc));
911 /* Statement functions are always scalar and functions. */
912 if (t == PROC_ST_FUNCTION
913 && ((!attr->function && gfc_add_function (attr, where) == FAILURE)
917 return check_conflict (attr, where);
922 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
925 if (check_used (attr, where))
928 if (attr->intent == INTENT_UNKNOWN)
930 attr->intent = intent;
931 return check_conflict (attr, where);
935 where = &gfc_current_locus;
937 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
938 gfc_intent_string (attr->intent),
939 gfc_intent_string (intent), where);
945 /* No checks for use-association in public and private statements. */
948 gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where)
951 if (attr->access == ACCESS_UNKNOWN)
953 attr->access = access;
954 return check_conflict (attr, where);
958 where = &gfc_current_locus;
959 gfc_error ("ACCESS specification at %L was already specified", where);
966 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
967 gfc_formal_arglist * formal, locus * where)
970 if (check_used (&sym->attr, where))
974 where = &gfc_current_locus;
976 if (sym->attr.if_source != IFSRC_UNKNOWN
977 && sym->attr.if_source != IFSRC_DECL)
979 gfc_error ("Symbol '%s' at %L already has an explicit interface",
984 sym->formal = formal;
985 sym->attr.if_source = source;
991 /* Add a type to a symbol. */
994 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
998 /* TODO: This is legal if it is reaffirming an implicit type.
999 if (check_done (&sym->attr, where))
1003 where = &gfc_current_locus;
1005 if (sym->ts.type != BT_UNKNOWN)
1007 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1008 where, gfc_basic_typename (sym->ts.type));
1012 flavor = sym->attr.flavor;
1014 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1015 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1016 && sym->attr.subroutine)
1017 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1019 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1028 /* Clears all attributes. */
1031 gfc_clear_attr (symbol_attribute * attr)
1034 attr->allocatable = 0;
1035 attr->dimension = 0;
1037 attr->intrinsic = 0;
1046 attr->use_assoc = 0;
1047 attr->in_namelist = 0;
1049 attr->in_common = 0;
1051 attr->subroutine = 0;
1053 attr->implicit_type = 0;
1055 attr->elemental = 0;
1057 attr->recursive = 0;
1059 attr->access = ACCESS_UNKNOWN;
1060 attr->intent = INTENT_UNKNOWN;
1061 attr->flavor = FL_UNKNOWN;
1062 attr->proc = PROC_UNKNOWN;
1063 attr->if_source = IFSRC_UNKNOWN;
1067 /* Check for missing attributes in the new symbol. Currently does
1068 nothing, but it's not clear that it is unnecessary yet. */
1071 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1072 locus * where ATTRIBUTE_UNUSED)
1079 /* Copy an attribute to a symbol attribute, bit by bit. Some
1080 attributes have a lot of side-effects but cannot be present given
1081 where we are called from, so we ignore some bits. */
1084 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1087 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1090 if (src->dimension && gfc_add_dimension (dest, where) == FAILURE)
1092 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1094 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1096 if (src->save && gfc_add_save (dest, where) == FAILURE)
1098 if (src->target && gfc_add_target (dest, where) == FAILURE)
1100 if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
1102 if (src->result && gfc_add_result (dest, where) == FAILURE)
1107 if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE)
1110 if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
1113 if (src->generic && gfc_add_generic (dest, where) == FAILURE)
1115 if (src->function && gfc_add_function (dest, where) == FAILURE)
1117 if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE)
1120 if (src->sequence && gfc_add_sequence (dest, where) == FAILURE)
1122 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1124 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1126 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1129 if (src->flavor != FL_UNKNOWN
1130 && gfc_add_flavor (dest, src->flavor, where) == FAILURE)
1133 if (src->intent != INTENT_UNKNOWN
1134 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1137 if (src->access != ACCESS_UNKNOWN
1138 && gfc_add_access (dest, src->access, where) == FAILURE)
1141 if (gfc_missing_attr (dest, where) == FAILURE)
1144 /* The subroutines that set these bits also cause flavors to be set,
1145 and that has already happened in the original, so don't let to
1150 dest->intrinsic = 1;
1159 /************** Component name management ************/
1161 /* Component names of a derived type form their own little namespaces
1162 that are separate from all other spaces. The space is composed of
1163 a singly linked list of gfc_component structures whose head is
1164 located in the parent symbol. */
1167 /* Add a component name to a symbol. The call fails if the name is
1168 already present. On success, the component pointer is modified to
1169 point to the additional component structure. */
1172 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1174 gfc_component *p, *tail;
1178 for (p = sym->components; p; p = p->next)
1180 if (strcmp (p->name, name) == 0)
1182 gfc_error ("Component '%s' at %C already declared at %L",
1190 /* Allocate new component */
1191 p = gfc_get_component ();
1194 sym->components = p;
1198 strcpy (p->name, name);
1199 p->loc = gfc_current_locus;
1206 /* Recursive function to switch derived types of all symbol in a
1210 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1218 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1219 sym->ts.derived = to;
1221 switch_types (st->left, from, to);
1222 switch_types (st->right, from, to);
1226 /* This subroutine is called when a derived type is used in order to
1227 make the final determination about which version to use. The
1228 standard requires that a type be defined before it is 'used', but
1229 such types can appear in IMPLICIT statements before the actual
1230 definition. 'Using' in this context means declaring a variable to
1231 be that type or using the type constructor.
1233 If a type is used and the components haven't been defined, then we
1234 have to have a derived type in a parent unit. We find the node in
1235 the other namespace and point the symtree node in this namespace to
1236 that node. Further reference to this name point to the correct
1237 node. If we can't find the node in a parent namespace, then have
1240 This subroutine takes a pointer to a symbol node and returns a
1241 pointer to the translated node or NULL for an error. Usually there
1242 is no translation and we return the node we were passed. */
1244 static gfc_symtree *
1245 gfc_use_ha_derived (gfc_symbol * sym)
1252 if (sym->ns->parent == NULL)
1255 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1257 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1261 if (s == NULL || s->attr.flavor != FL_DERIVED)
1264 /* Get rid of symbol sym, translating all references to s. */
1265 for (i = 0; i < GFC_LETTERS; i++)
1267 t = &sym->ns->default_type[i];
1268 if (t->derived == sym)
1272 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1277 /* Unlink from list of modified symbols. */
1278 if (changed_syms == sym)
1279 changed_syms = sym->tlink;
1281 for (p = changed_syms; p; p = p->tlink)
1282 if (p->tlink == sym)
1284 p->tlink = sym->tlink;
1288 switch_types (sym->ns->sym_root, sym, s);
1290 /* TODO: Also have to replace sym -> s in other lists like
1291 namelists, common lists and interface lists. */
1292 gfc_free_symbol (sym);
1297 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1304 gfc_use_derived (gfc_symbol * sym)
1308 if (sym->components != NULL)
1309 return sym; /* Already defined */
1311 st = gfc_use_ha_derived (sym);
1319 /* Given a derived type node and a component name, try to locate the
1320 component structure. Returns the NULL pointer if the component is
1321 not found or the components are private. */
1324 gfc_find_component (gfc_symbol * sym, const char *name)
1331 sym = gfc_use_derived (sym);
1336 for (p = sym->components; p; p = p->next)
1337 if (strcmp (p->name, name) == 0)
1341 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1345 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1347 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1357 /* Given a symbol, free all of the component structures and everything
1361 free_components (gfc_component * p)
1369 gfc_free_array_spec (p->as);
1370 gfc_free_expr (p->initializer);
1377 /* Set component attributes from a standard symbol attribute
1381 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1384 c->dimension = attr->dimension;
1385 c->pointer = attr->pointer;
1389 /* Get a standard symbol attribute structure given the component
1393 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1396 gfc_clear_attr (attr);
1397 attr->dimension = c->dimension;
1398 attr->pointer = c->pointer;
1402 /******************** Statement label management ********************/
1404 /* Free a single gfc_st_label structure, making sure the list is not
1405 messed up. This function is called only when some parse error
1409 gfc_free_st_label (gfc_st_label * l)
1416 (l->prev->next = l->next);
1419 (l->next->prev = l->prev);
1421 if (l->format != NULL)
1422 gfc_free_expr (l->format);
1426 /* Free a whole list of gfc_st_label structures. */
1429 free_st_labels (gfc_st_label * l1)
1436 if (l1->format != NULL)
1437 gfc_free_expr (l1->format);
1443 /* Given a label number, search for and return a pointer to the label
1444 structure, creating it if it does not exist. */
1447 gfc_get_st_label (int labelno)
1451 /* First see if the label is already in this namespace. */
1452 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1453 if (lp->value == labelno)
1458 lp = gfc_getmem (sizeof (gfc_st_label));
1460 lp->value = labelno;
1461 lp->defined = ST_LABEL_UNKNOWN;
1462 lp->referenced = ST_LABEL_UNKNOWN;
1465 lp->next = gfc_current_ns->st_labels;
1466 if (gfc_current_ns->st_labels)
1467 gfc_current_ns->st_labels->prev = lp;
1468 gfc_current_ns->st_labels = lp;
1474 /* Called when a statement with a statement label is about to be
1475 accepted. We add the label to the list of the current namespace,
1476 making sure it hasn't been defined previously and referenced
1480 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1484 labelno = lp->value;
1486 if (lp->defined != ST_LABEL_UNKNOWN)
1487 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1488 &lp->where, label_locus);
1491 lp->where = *label_locus;
1495 case ST_LABEL_FORMAT:
1496 if (lp->referenced == ST_LABEL_TARGET)
1497 gfc_error ("Label %d at %C already referenced as branch target",
1500 lp->defined = ST_LABEL_FORMAT;
1504 case ST_LABEL_TARGET:
1505 if (lp->referenced == ST_LABEL_FORMAT)
1506 gfc_error ("Label %d at %C already referenced as a format label",
1509 lp->defined = ST_LABEL_TARGET;
1514 lp->defined = ST_LABEL_BAD_TARGET;
1515 lp->referenced = ST_LABEL_BAD_TARGET;
1521 /* Reference a label. Given a label and its type, see if that
1522 reference is consistent with what is known about that label,
1523 updating the unknown state. Returns FAILURE if something goes
1527 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1529 gfc_sl_type label_type;
1536 labelno = lp->value;
1538 if (lp->defined != ST_LABEL_UNKNOWN)
1539 label_type = lp->defined;
1542 label_type = lp->referenced;
1543 lp->where = gfc_current_locus;
1546 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1548 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1553 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1554 && type == ST_LABEL_FORMAT)
1556 gfc_error ("Label %d at %C previously used as branch target", labelno);
1561 lp->referenced = type;
1569 /************** Symbol table management subroutines ****************/
1571 /* Basic details: Fortran 95 requires a potentially unlimited number
1572 of distinct namespaces when compiling a program unit. This case
1573 occurs during a compilation of internal subprograms because all of
1574 the internal subprograms must be read before we can start
1575 generating code for the host.
1577 Given the tricky nature of the fortran grammar, we must be able to
1578 undo changes made to a symbol table if the current interpretation
1579 of a statement is found to be incorrect. Whenever a symbol is
1580 looked up, we make a copy of it and link to it. All of these
1581 symbols are kept in a singly linked list so that we can commit or
1582 undo the changes at a later time.
1584 A symtree may point to a symbol node outside of it's namespace. In
1585 this case, that symbol has been used as a host associated variable
1586 at some previous time. */
1588 /* Allocate a new namespace structure. */
1591 gfc_get_namespace (gfc_namespace * parent)
1595 gfc_intrinsic_op in;
1598 ns = gfc_getmem (sizeof (gfc_namespace));
1599 ns->sym_root = NULL;
1600 ns->uop_root = NULL;
1601 ns->default_access = ACCESS_UNKNOWN;
1602 ns->parent = parent;
1604 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1605 ns->operator_access[in] = ACCESS_UNKNOWN;
1607 /* Initialize default implicit types. */
1608 for (i = 'a'; i <= 'z'; i++)
1610 ns->set_flag[i - 'a'] = 0;
1611 ts = &ns->default_type[i - 'a'];
1613 if (ns->parent != NULL)
1615 /* Copy parent settings */
1616 *ts = ns->parent->default_type[i - 'a'];
1620 if (gfc_option.flag_implicit_none != 0)
1626 if ('i' <= i && i <= 'n')
1628 ts->type = BT_INTEGER;
1629 ts->kind = gfc_default_integer_kind ();
1634 ts->kind = gfc_default_real_kind ();
1642 /* Comparison function for symtree nodes. */
1645 compare_symtree (void * _st1, void * _st2)
1647 gfc_symtree *st1, *st2;
1649 st1 = (gfc_symtree *) _st1;
1650 st2 = (gfc_symtree *) _st2;
1652 return strcmp (st1->name, st2->name);
1656 /* Allocate a new symtree node and associate it with the new symbol. */
1659 gfc_new_symtree (gfc_symtree ** root, const char *name)
1663 st = gfc_getmem (sizeof (gfc_symtree));
1664 strcpy (st->name, name);
1666 gfc_insert_bbt (root, st, compare_symtree);
1671 /* Delete a symbol from the tree. Does not free the symbol itself! */
1674 delete_symtree (gfc_symtree ** root, const char *name)
1676 gfc_symtree st, *st0;
1678 st0 = gfc_find_symtree (*root, name);
1680 strcpy (st.name, name);
1681 gfc_delete_bbt (root, &st, compare_symtree);
1687 /* Given a root symtree node and a name, try to find the symbol within
1688 the namespace. Returns NULL if the symbol is not found. */
1691 gfc_find_symtree (gfc_symtree * st, const char *name)
1697 c = strcmp (name, st->name);
1701 st = (c < 0) ? st->left : st->right;
1708 /* Given a name find a user operator node, creating it if it doesn't
1709 exist. These are much simpler than symbols because they can't be
1710 ambiguous with one another. */
1713 gfc_get_uop (const char *name)
1718 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1722 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1724 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1725 strcpy (uop->name, name);
1726 uop->access = ACCESS_UNKNOWN;
1727 uop->ns = gfc_current_ns;
1733 /* Given a name find the user operator node. Returns NULL if it does
1737 gfc_find_uop (const char *name, gfc_namespace * ns)
1742 ns = gfc_current_ns;
1744 st = gfc_find_symtree (ns->uop_root, name);
1745 return (st == NULL) ? NULL : st->n.uop;
1749 /* Remove a gfc_symbol structure and everything it points to. */
1752 gfc_free_symbol (gfc_symbol * sym)
1758 gfc_free_array_spec (sym->as);
1760 free_components (sym->components);
1762 gfc_free_expr (sym->value);
1764 gfc_free_namelist (sym->namelist);
1766 gfc_free_namespace (sym->formal_ns);
1768 gfc_free_interface (sym->generic);
1770 gfc_free_formal_arglist (sym->formal);
1776 /* Allocate and initialize a new symbol node. */
1779 gfc_new_symbol (const char *name, gfc_namespace * ns)
1783 p = gfc_getmem (sizeof (gfc_symbol));
1785 gfc_clear_ts (&p->ts);
1786 gfc_clear_attr (&p->attr);
1789 p->declared_at = gfc_current_locus;
1791 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1792 gfc_internal_error ("new_symbol(): Symbol name too long");
1794 strcpy (p->name, name);
1799 /* Generate an error if a symbol is ambiguous. */
1802 ambiguous_symbol (const char *name, gfc_symtree * st)
1805 if (st->n.sym->module[0])
1806 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1807 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1809 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1810 "from current program unit", name, st->n.sym->name);
1814 /* Search for a symbol starting in the current namespace, resorting to
1815 any parent namespaces if requested by a nonzero parent_flag.
1816 Returns nonzero if the symbol is ambiguous. */
1819 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1820 gfc_symtree ** result)
1825 ns = gfc_current_ns;
1829 st = gfc_find_symtree (ns->sym_root, name);
1835 ambiguous_symbol (name, st);
1855 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1856 gfc_symbol ** result)
1861 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1866 *result = st->n.sym;
1872 /* Save symbol with the information necessary to back it out. */
1875 save_symbol_data (gfc_symbol * sym)
1878 if (sym->new || sym->old_symbol != NULL)
1881 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1882 *(sym->old_symbol) = *sym;
1884 sym->tlink = changed_syms;
1889 /* Given a name, find a symbol, or create it if it does not exist yet
1890 in the current namespace. If the symbol is found we make sure that
1893 The integer return code indicates
1895 1 The symbol name was ambiguous
1896 2 The name meant to be established was already host associated.
1898 So if the return value is nonzero, then an error was issued. */
1901 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1906 /* This doesn't usually happen during resolution. */
1908 ns = gfc_current_ns;
1910 /* Try to find the symbol in ns. */
1911 st = gfc_find_symtree (ns->sym_root, name);
1915 /* If not there, create a new symbol. */
1916 p = gfc_new_symbol (name, ns);
1918 /* Add to the list of tentative symbols. */
1919 p->old_symbol = NULL;
1920 p->tlink = changed_syms;
1925 st = gfc_new_symtree (&ns->sym_root, name);
1932 /* Make sure the existing symbol is OK. */
1935 ambiguous_symbol (name, st);
1941 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1943 /* Symbol is from another namespace. */
1944 gfc_error ("Symbol '%s' at %C has already been host associated",
1951 /* Copy in case this symbol is changed. */
1952 save_symbol_data (p);
1961 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1967 i = gfc_get_sym_tree (name, ns, &st);
1972 *result = st->n.sym;
1979 /* Subroutine that searches for a symbol, creating it if it doesn't
1980 exist, but tries to host-associate the symbol if possible. */
1983 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1988 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1991 save_symbol_data (st->n.sym);
1997 if (gfc_current_ns->parent != NULL)
1999 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2010 return gfc_get_sym_tree (name, gfc_current_ns, result);
2015 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
2020 i = gfc_get_ha_sym_tree (name, &st);
2023 *result = st->n.sym;
2030 /* Return true if both symbols could refer to the same data object. Does
2031 not take account of aliasing due to equivalence statements. */
2034 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
2036 /* Aliasing isn't possible if the symbols have different base types. */
2037 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2040 /* Pointers can point to other pointers, target objects and allocatable
2041 objects. Two allocatable objects cannot share the same storage. */
2042 if (lsym->attr.pointer
2043 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2045 if (lsym->attr.target && rsym->attr.pointer)
2047 if (lsym->attr.allocatable && rsym->attr.pointer)
2054 /* Undoes all the changes made to symbols in the current statement.
2055 This subroutine is made simpler due to the fact that attributes are
2056 never removed once added. */
2059 gfc_undo_symbols (void)
2061 gfc_symbol *p, *q, *old;
2063 for (p = changed_syms; p; p = q)
2069 /* Symbol was new. */
2070 delete_symtree (&p->ns->sym_root, p->name);
2074 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2076 gfc_free_symbol (p);
2080 /* Restore previous state of symbol. Just copy simple stuff. */
2082 old = p->old_symbol;
2084 p->ts.type = old->ts.type;
2085 p->ts.kind = old->ts.kind;
2087 p->attr = old->attr;
2089 if (p->value != old->value)
2091 gfc_free_expr (old->value);
2095 if (p->as != old->as)
2098 gfc_free_array_spec (p->as);
2102 p->generic = old->generic;
2103 p->component_access = old->component_access;
2105 if (p->namelist != NULL && old->namelist == NULL)
2107 gfc_free_namelist (p->namelist);
2113 if (p->namelist_tail != old->namelist_tail)
2115 gfc_free_namelist (old->namelist_tail);
2116 old->namelist_tail->next = NULL;
2120 p->namelist_tail = old->namelist_tail;
2122 if (p->formal != old->formal)
2124 gfc_free_formal_arglist (p->formal);
2125 p->formal = old->formal;
2128 gfc_free (p->old_symbol);
2129 p->old_symbol = NULL;
2133 changed_syms = NULL;
2137 /* Makes the changes made in the current statement permanent-- gets
2138 rid of undo information. */
2141 gfc_commit_symbols (void)
2145 for (p = changed_syms; p; p = q)
2152 if (p->old_symbol != NULL)
2154 gfc_free (p->old_symbol);
2155 p->old_symbol = NULL;
2159 changed_syms = NULL;
2163 /* Recursive function that deletes an entire tree and all the user
2164 operator nodes that it contains. */
2167 free_uop_tree (gfc_symtree * uop_tree)
2170 if (uop_tree == NULL)
2173 free_uop_tree (uop_tree->left);
2174 free_uop_tree (uop_tree->right);
2176 gfc_free_interface (uop_tree->n.uop->operator);
2178 gfc_free (uop_tree->n.uop);
2179 gfc_free (uop_tree);
2183 /* Recursive function that deletes an entire tree and all the symbols
2184 that it contains. */
2187 free_sym_tree (gfc_symtree * sym_tree)
2192 if (sym_tree == NULL)
2195 free_sym_tree (sym_tree->left);
2196 free_sym_tree (sym_tree->right);
2198 sym = sym_tree->n.sym;
2202 gfc_internal_error ("free_sym_tree(): Negative refs");
2204 if (sym->formal_ns != NULL && sym->refs == 1)
2206 /* As formal_ns contains a reference to sym, delete formal_ns just
2207 before the deletion of sym. */
2208 ns = sym->formal_ns;
2209 sym->formal_ns = NULL;
2210 gfc_free_namespace (ns);
2212 else if (sym->refs == 0)
2214 /* Go ahead and delete the symbol. */
2215 gfc_free_symbol (sym);
2218 gfc_free (sym_tree);
2222 /* Free a namespace structure and everything below it. Interface
2223 lists associated with intrinsic operators are not freed. These are
2224 taken care of when a specific name is freed. */
2227 gfc_free_namespace (gfc_namespace * ns)
2229 gfc_charlen *cl, *cl2;
2230 gfc_namespace *p, *q;
2236 gfc_free_statements (ns->code);
2238 free_sym_tree (ns->sym_root);
2239 free_uop_tree (ns->uop_root);
2241 for (cl = ns->cl_list; cl; cl = cl2)
2244 gfc_free_expr (cl->length);
2248 free_st_labels (ns->st_labels);
2250 gfc_free_equiv (ns->equiv);
2252 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2253 gfc_free_interface (ns->operator[i]);
2255 gfc_free_data (ns->data);
2259 /* Recursively free any contained namespaces. */
2265 gfc_free_namespace (q);
2271 gfc_symbol_init_2 (void)
2274 gfc_current_ns = gfc_get_namespace (NULL);
2279 gfc_symbol_done_2 (void)
2282 gfc_free_namespace (gfc_current_ns);
2283 gfc_current_ns = NULL;
2287 /* Clear mark bits from symbol nodes associated with a symtree node. */
2290 clear_sym_mark (gfc_symtree * st)
2293 st->n.sym->mark = 0;
2297 /* Recursively traverse the symtree nodes. */
2300 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2306 gfc_traverse_symtree (st->left, func);
2307 gfc_traverse_symtree (st->right, func);
2312 /* Recursive namespace traversal function. */
2315 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2321 if (st->n.sym->mark == 0)
2322 (*func) (st->n.sym);
2323 st->n.sym->mark = 1;
2325 traverse_ns (st->left, func);
2326 traverse_ns (st->right, func);
2330 /* Call a given function for all symbols in the namespace. We take
2331 care that each gfc_symbol node is called exactly once. */
2334 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2337 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2339 traverse_ns (ns->sym_root, func);
2343 /* Given a symbol, mark it as SAVEd if it is allowed. */
2346 save_symbol (gfc_symbol * sym)
2349 if (sym->attr.use_assoc)
2352 if (sym->attr.in_common
2354 || sym->attr.flavor != FL_VARIABLE)
2357 gfc_add_save (&sym->attr, &sym->declared_at);
2361 /* Mark those symbols which can be SAVEd as such. */
2364 gfc_save_all (gfc_namespace * ns)
2367 gfc_traverse_ns (ns, save_symbol);
2372 /* Make sure that no changes to symbols are pending. */
2375 gfc_symbol_state(void) {
2377 if (changed_syms != NULL)
2378 gfc_internal_error("Symbol changes still pending!");
2383 /************** Global symbol handling ************/
2386 /* Search a tree for the global symbol. */
2389 gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
2395 if (strcmp (symbol->name, name) == 0)
2398 s = gfc_find_gsymbol (symbol->left, name);
2402 s = gfc_find_gsymbol (symbol->right, name);
2410 /* Compare two global symbols. Used for managing the BB tree. */
2413 gsym_compare (void * _s1, void * _s2)
2415 gfc_gsymbol *s1, *s2;
2417 s1 = (gfc_gsymbol *)_s1;
2418 s2 = (gfc_gsymbol *)_s2;
2419 return strcmp(s1->name, s2->name);
2423 /* Get a global symbol, creating it if it doesn't exist. */
2426 gfc_get_gsymbol (char *name)
2430 s = gfc_find_gsymbol (gfc_gsym_root, name);
2434 s = gfc_getmem (sizeof (gfc_gsymbol));
2435 s->type = GSYM_UNKNOWN;
2436 strcpy (s->name, name);
2438 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);