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
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
41 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
42 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
43 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
47 const mstring procedures[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50 minit ("MODULE-PROC", PROC_MODULE),
51 minit ("INTERNAL-PROC", PROC_INTERNAL),
52 minit ("DUMMY-PROC", PROC_DUMMY),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
59 const mstring intents[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62 minit ("IN", INTENT_IN),
63 minit ("OUT", INTENT_OUT),
64 minit ("INOUT", INTENT_INOUT),
68 const mstring access_types[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71 minit ("PUBLIC", ACCESS_PUBLIC),
72 minit ("PRIVATE", ACCESS_PRIVATE),
76 const mstring ifsrc_types[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN),
79 minit ("DECL", IFSRC_DECL),
80 minit ("BODY", IFSRC_IFBODY),
81 minit ("USAGE", IFSRC_USAGE)
85 /* This is to make sure the backend generates setup code in the correct
88 static int next_dummy_order = 1;
91 gfc_namespace *gfc_current_ns;
93 gfc_gsymbol *gfc_gsym_root = NULL;
95 static gfc_symbol *changed_syms = NULL;
98 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
100 /* The following static variable indicates whether a particular element has
101 been explicitly set or not. */
103 static int new_flag[GFC_LETTERS];
106 /* Handle a correctly parsed IMPLICIT NONE. */
109 gfc_set_implicit_none (void)
113 for (i = 0; i < GFC_LETTERS; i++)
115 gfc_clear_ts (&gfc_current_ns->default_type[i]);
116 gfc_current_ns->set_flag[i] = 1;
121 /* Reset the implicit range flags. */
124 gfc_clear_new_implicit (void)
128 for (i = 0; i < GFC_LETTERS; i++)
133 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
136 gfc_add_new_implicit_range (int c1, int c2)
143 for (i = c1; i <= c2; i++)
147 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
159 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
160 the new implicit types back into the existing types will work. */
163 gfc_merge_new_implicit (gfc_typespec * ts)
167 for (i = 0; i < GFC_LETTERS; i++)
172 if (gfc_current_ns->set_flag[i])
174 gfc_error ("Letter %c already has an IMPLICIT type at %C",
178 gfc_current_ns->default_type[i] = *ts;
179 gfc_current_ns->set_flag[i] = 1;
186 /* Given a symbol, return a pointer to the typespec for it's default
190 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
194 letter = sym->name[0];
195 if (letter < 'a' || letter > 'z')
196 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
201 return &ns->default_type[letter - 'a'];
205 /* Given a pointer to a symbol, set its type according to the first
206 letter of its name. Fails if the letter in question has no default
210 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
214 if (sym->ts.type != BT_UNKNOWN)
215 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
217 ts = gfc_get_default_type (sym, ns);
219 if (ts->type == BT_UNKNOWN)
222 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
229 sym->attr.implicit_type = 1;
235 /******************** Symbol attribute stuff *********************/
237 /* This is a generic conflict-checker. We do this to avoid having a
238 single conflict in two places. */
240 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
241 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
244 check_conflict (symbol_attribute * attr, locus * where)
246 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
247 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
248 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
249 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
250 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
251 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
252 *function = "FUNCTION", *subroutine = "SUBROUTINE",
253 *dimension = "DIMENSION";
258 where = &gfc_current_locus;
260 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
267 /* Check for attributes not allowed in a BLOCK DATA. */
268 if (gfc_current_state () == COMP_BLOCK_DATA)
272 if (attr->allocatable)
278 if (attr->access == ACCESS_PRIVATE)
280 if (attr->access == ACCESS_PUBLIC)
282 if (attr->intent != INTENT_UNKNOWN)
288 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
295 conf (pointer, target);
296 conf (pointer, external);
297 conf (pointer, intrinsic);
298 conf (target, external);
299 conf (target, intrinsic);
300 conf (external, dimension); /* See Fortran 95's R504. */
302 conf (external, intrinsic);
303 conf (allocatable, pointer);
304 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
305 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
306 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
307 conf (elemental, recursive);
309 conf (in_common, dummy);
310 conf (in_common, allocatable);
311 conf (in_common, result);
312 conf (dummy, result);
314 conf (in_namelist, pointer);
315 conf (in_namelist, allocatable);
317 conf (entry, result);
319 conf (function, subroutine);
321 a1 = gfc_code2string (flavors, attr->flavor);
323 if (attr->in_namelist
324 && attr->flavor != FL_VARIABLE
325 && attr->flavor != FL_UNKNOWN)
332 switch (attr->flavor)
359 if (attr->subroutine)
372 case PROC_ST_FUNCTION:
405 if (attr->intent != INTENT_UNKNOWN)
433 gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where);
441 /* Mark a symbol as referenced. */
444 gfc_set_sym_referenced (gfc_symbol * sym)
446 if (sym->attr.referenced)
449 sym->attr.referenced = 1;
451 /* Remember which order dummy variables are accessed in. */
453 sym->dummy_order = next_dummy_order++;
457 /* Common subroutine called by attribute changing subroutines in order
458 to prevent them from changing a symbol that has been
459 use-associated. Returns zero if it is OK to change the symbol,
463 check_used (symbol_attribute * attr, locus * where)
466 if (attr->use_assoc == 0)
470 where = &gfc_current_locus;
472 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
479 /* Used to prevent changing the attributes of a symbol after it has been
480 used. This check is only done from dummy variable as only these can be
481 used in specification expressions. Applying this to all symbols causes
482 error when we reach the body of a contained function. */
485 check_done (symbol_attribute * attr, locus * where)
488 if (!(attr->dummy && attr->referenced))
492 where = &gfc_current_locus;
494 gfc_error ("Cannot change attributes of symbol at %L"
495 " after it has been used", where);
501 /* Generate an error because of a duplicate attribute. */
504 duplicate_attr (const char *attr, locus * where)
508 where = &gfc_current_locus;
510 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
515 gfc_add_allocatable (symbol_attribute * attr, locus * where)
518 if (check_used (attr, where) || check_done (attr, where))
521 if (attr->allocatable)
523 duplicate_attr ("ALLOCATABLE", where);
527 attr->allocatable = 1;
528 return check_conflict (attr, where);
533 gfc_add_dimension (symbol_attribute * attr, locus * where)
536 if (check_used (attr, where) || check_done (attr, where))
541 duplicate_attr ("DIMENSION", where);
546 return check_conflict (attr, where);
551 gfc_add_external (symbol_attribute * attr, locus * where)
554 if (check_used (attr, where) || check_done (attr, where))
559 duplicate_attr ("EXTERNAL", where);
565 return check_conflict (attr, where);
570 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
573 if (check_used (attr, where) || check_done (attr, where))
578 duplicate_attr ("INTRINSIC", where);
584 return check_conflict (attr, where);
589 gfc_add_optional (symbol_attribute * attr, locus * where)
592 if (check_used (attr, where) || check_done (attr, where))
597 duplicate_attr ("OPTIONAL", where);
602 return check_conflict (attr, where);
607 gfc_add_pointer (symbol_attribute * attr, locus * where)
610 if (check_used (attr, where) || check_done (attr, where))
614 return check_conflict (attr, where);
619 gfc_add_result (symbol_attribute * attr, locus * where)
622 if (check_used (attr, where) || check_done (attr, where))
626 return check_conflict (attr, where);
631 gfc_add_save (symbol_attribute * attr, locus * where)
634 if (check_used (attr, where))
640 ("SAVE attribute at %L cannot be specified in a PURE procedure",
647 duplicate_attr ("SAVE", where);
652 return check_conflict (attr, where);
657 gfc_add_target (symbol_attribute * attr, locus * where)
660 if (check_used (attr, where) || check_done (attr, where))
665 duplicate_attr ("TARGET", where);
670 return check_conflict (attr, where);
675 gfc_add_dummy (symbol_attribute * attr, locus * where)
678 if (check_used (attr, where))
681 /* Duplicate dummy arguments are allow due to ENTRY statements. */
683 return check_conflict (attr, where);
688 gfc_add_in_common (symbol_attribute * attr, locus * where)
691 if (check_used (attr, where) || check_done (attr, where))
694 /* Duplicate attribute already checked for. */
696 if (check_conflict (attr, where) == FAILURE)
699 if (attr->flavor == FL_VARIABLE)
702 return gfc_add_flavor (attr, FL_VARIABLE, where);
707 gfc_add_data (symbol_attribute *attr, locus *where)
710 if (check_used (attr, where))
714 return check_conflict (attr, where);
719 gfc_add_in_namelist (symbol_attribute * attr, locus * where)
722 attr->in_namelist = 1;
723 return check_conflict (attr, where);
728 gfc_add_sequence (symbol_attribute * attr, locus * where)
731 if (check_used (attr, where))
735 return check_conflict (attr, where);
740 gfc_add_elemental (symbol_attribute * attr, locus * where)
743 if (check_used (attr, where) || check_done (attr, where))
747 return check_conflict (attr, where);
752 gfc_add_pure (symbol_attribute * attr, locus * where)
755 if (check_used (attr, where) || check_done (attr, where))
759 return check_conflict (attr, where);
764 gfc_add_recursive (symbol_attribute * attr, locus * where)
767 if (check_used (attr, where) || check_done (attr, where))
771 return check_conflict (attr, where);
776 gfc_add_entry (symbol_attribute * attr, locus * where)
779 if (check_used (attr, where))
784 duplicate_attr ("ENTRY", where);
789 return check_conflict (attr, where);
794 gfc_add_function (symbol_attribute * attr, locus * where)
797 if (attr->flavor != FL_PROCEDURE
798 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
802 return check_conflict (attr, where);
807 gfc_add_subroutine (symbol_attribute * attr, locus * where)
810 if (attr->flavor != FL_PROCEDURE
811 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
814 attr->subroutine = 1;
815 return check_conflict (attr, where);
820 gfc_add_generic (symbol_attribute * attr, locus * where)
823 if (attr->flavor != FL_PROCEDURE
824 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
828 return check_conflict (attr, where);
832 /* Flavors are special because some flavors are not what fortran
833 considers attributes and can be reaffirmed multiple times. */
836 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
839 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
840 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
841 || f == FL_NAMELIST) && check_used (attr, where))
844 if (attr->flavor == f && f == FL_VARIABLE)
847 if (attr->flavor != FL_UNKNOWN)
850 where = &gfc_current_locus;
852 gfc_error ("%s attribute conflicts with %s attribute at %L",
853 gfc_code2string (flavors, attr->flavor),
854 gfc_code2string (flavors, f), where);
861 return check_conflict (attr, where);
866 gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
869 if (check_used (attr, where) || check_done (attr, where))
872 if (attr->flavor != FL_PROCEDURE
873 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
877 where = &gfc_current_locus;
879 if (attr->proc != PROC_UNKNOWN)
881 gfc_error ("%s procedure at %L is already %s %s procedure",
882 gfc_code2string (procedures, t), where,
883 gfc_article (gfc_code2string (procedures, attr->proc)),
884 gfc_code2string (procedures, attr->proc));
891 /* Statement functions are always scalar and functions. */
892 if (t == PROC_ST_FUNCTION
893 && ((!attr->function && gfc_add_function (attr, where) == FAILURE)
897 return check_conflict (attr, where);
902 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
905 if (check_used (attr, where))
908 if (attr->intent == INTENT_UNKNOWN)
910 attr->intent = intent;
911 return check_conflict (attr, where);
915 where = &gfc_current_locus;
917 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
918 gfc_intent_string (attr->intent),
919 gfc_intent_string (intent), where);
925 /* No checks for use-association in public and private statements. */
928 gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where)
931 if (attr->access == ACCESS_UNKNOWN)
933 attr->access = access;
934 return check_conflict (attr, where);
938 where = &gfc_current_locus;
939 gfc_error ("ACCESS specification at %L was already specified", where);
946 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
947 gfc_formal_arglist * formal, locus * where)
950 if (check_used (&sym->attr, where))
954 where = &gfc_current_locus;
956 if (sym->attr.if_source != IFSRC_UNKNOWN
957 && sym->attr.if_source != IFSRC_DECL)
959 gfc_error ("Symbol '%s' at %L already has an explicit interface",
964 sym->formal = formal;
965 sym->attr.if_source = source;
971 /* Add a type to a symbol. */
974 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
978 /* TODO: This is legal if it is reaffirming an implicit type.
979 if (check_done (&sym->attr, where))
983 where = &gfc_current_locus;
985 if (sym->ts.type != BT_UNKNOWN)
987 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
988 where, gfc_basic_typename (sym->ts.type));
992 flavor = sym->attr.flavor;
994 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
995 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
996 && sym->attr.subroutine)
997 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
999 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1008 /* Clears all attributes. */
1011 gfc_clear_attr (symbol_attribute * attr)
1014 attr->allocatable = 0;
1015 attr->dimension = 0;
1017 attr->intrinsic = 0;
1026 attr->use_assoc = 0;
1027 attr->in_namelist = 0;
1029 attr->in_common = 0;
1031 attr->subroutine = 0;
1033 attr->implicit_type = 0;
1035 attr->elemental = 0;
1037 attr->recursive = 0;
1039 attr->access = ACCESS_UNKNOWN;
1040 attr->intent = INTENT_UNKNOWN;
1041 attr->flavor = FL_UNKNOWN;
1042 attr->proc = PROC_UNKNOWN;
1043 attr->if_source = IFSRC_UNKNOWN;
1047 /* Check for missing attributes in the new symbol. Currently does
1048 nothing, but it's not clear that it is unnecessary yet. */
1051 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1052 locus * where ATTRIBUTE_UNUSED)
1059 /* Copy an attribute to a symbol attribute, bit by bit. Some
1060 attributes have a lot of side-effects but cannot be present given
1061 where we are called from, so we ignore some bits. */
1064 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1067 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1070 if (src->dimension && gfc_add_dimension (dest, where) == FAILURE)
1072 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1074 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1076 if (src->save && gfc_add_save (dest, where) == FAILURE)
1078 if (src->target && gfc_add_target (dest, where) == FAILURE)
1080 if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
1082 if (src->result && gfc_add_result (dest, where) == FAILURE)
1087 if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE)
1090 if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
1093 if (src->generic && gfc_add_generic (dest, where) == FAILURE)
1095 if (src->function && gfc_add_function (dest, where) == FAILURE)
1097 if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE)
1100 if (src->sequence && gfc_add_sequence (dest, where) == FAILURE)
1102 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1104 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1106 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1109 if (src->flavor != FL_UNKNOWN
1110 && gfc_add_flavor (dest, src->flavor, where) == FAILURE)
1113 if (src->intent != INTENT_UNKNOWN
1114 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1117 if (src->access != ACCESS_UNKNOWN
1118 && gfc_add_access (dest, src->access, where) == FAILURE)
1121 if (gfc_missing_attr (dest, where) == FAILURE)
1124 /* The subroutines that set these bits also cause flavors to be set,
1125 and that has already happened in the original, so don't let to
1130 dest->intrinsic = 1;
1139 /************** Component name management ************/
1141 /* Component names of a derived type form their own little namespaces
1142 that are separate from all other spaces. The space is composed of
1143 a singly linked list of gfc_component structures whose head is
1144 located in the parent symbol. */
1147 /* Add a component name to a symbol. The call fails if the name is
1148 already present. On success, the component pointer is modified to
1149 point to the additional component structure. */
1152 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1154 gfc_component *p, *tail;
1158 for (p = sym->components; p; p = p->next)
1160 if (strcmp (p->name, name) == 0)
1162 gfc_error ("Component '%s' at %C already declared at %L",
1170 /* Allocate new component */
1171 p = gfc_get_component ();
1174 sym->components = p;
1178 strcpy (p->name, name);
1179 p->loc = gfc_current_locus;
1186 /* Recursive function to switch derived types of all symbol in a
1190 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1198 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1199 sym->ts.derived = to;
1201 switch_types (st->left, from, to);
1202 switch_types (st->right, from, to);
1206 /* This subroutine is called when a derived type is used in order to
1207 make the final determination about which version to use. The
1208 standard requires that a type be defined before it is 'used', but
1209 such types can appear in IMPLICIT statements before the actual
1210 definition. 'Using' in this context means declaring a variable to
1211 be that type or using the type constructor.
1213 If a type is used and the components haven't been defined, then we
1214 have to have a derived type in a parent unit. We find the node in
1215 the other namespace and point the symtree node in this namespace to
1216 that node. Further reference to this name point to the correct
1217 node. If we can't find the node in a parent namespace, then have
1220 This subroutine takes a pointer to a symbol node and returns a
1221 pointer to the translated node or NULL for an error. Usually there
1222 is no translation and we return the node we were passed. */
1224 static gfc_symtree *
1225 gfc_use_ha_derived (gfc_symbol * sym)
1232 if (sym->ns->parent == NULL)
1235 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1237 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1241 if (s == NULL || s->attr.flavor != FL_DERIVED)
1244 /* Get rid of symbol sym, translating all references to s. */
1245 for (i = 0; i < GFC_LETTERS; i++)
1247 t = &sym->ns->default_type[i];
1248 if (t->derived == sym)
1252 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1257 /* Unlink from list of modified symbols. */
1258 if (changed_syms == sym)
1259 changed_syms = sym->tlink;
1261 for (p = changed_syms; p; p = p->tlink)
1262 if (p->tlink == sym)
1264 p->tlink = sym->tlink;
1268 switch_types (sym->ns->sym_root, sym, s);
1270 /* TODO: Also have to replace sym -> s in other lists like
1271 namelists, common lists and interface lists. */
1272 gfc_free_symbol (sym);
1277 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1284 gfc_use_derived (gfc_symbol * sym)
1288 if (sym->components != NULL)
1289 return sym; /* Already defined */
1291 st = gfc_use_ha_derived (sym);
1299 /* Given a derived type node and a component name, try to locate the
1300 component structure. Returns the NULL pointer if the component is
1301 not found or the components are private. */
1304 gfc_find_component (gfc_symbol * sym, const char *name)
1311 sym = gfc_use_derived (sym);
1316 for (p = sym->components; p; p = p->next)
1317 if (strcmp (p->name, name) == 0)
1321 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1325 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1327 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1337 /* Given a symbol, free all of the component structures and everything
1341 free_components (gfc_component * p)
1349 gfc_free_array_spec (p->as);
1350 gfc_free_expr (p->initializer);
1357 /* Set component attributes from a standard symbol attribute
1361 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1364 c->dimension = attr->dimension;
1365 c->pointer = attr->pointer;
1369 /* Get a standard symbol attribute structure given the component
1373 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1376 gfc_clear_attr (attr);
1377 attr->dimension = c->dimension;
1378 attr->pointer = c->pointer;
1382 /******************** Statement label management ********************/
1384 /* Free a single gfc_st_label structure, making sure the list is not
1385 messed up. This function is called only when some parse error
1389 gfc_free_st_label (gfc_st_label * l)
1396 (l->prev->next = l->next);
1399 (l->next->prev = l->prev);
1401 if (l->format != NULL)
1402 gfc_free_expr (l->format);
1406 /* Free a whole list of gfc_st_label structures. */
1409 free_st_labels (gfc_st_label * l1)
1416 if (l1->format != NULL)
1417 gfc_free_expr (l1->format);
1423 /* Given a label number, search for and return a pointer to the label
1424 structure, creating it if it does not exist. */
1427 gfc_get_st_label (int labelno)
1431 /* First see if the label is already in this namespace. */
1432 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1433 if (lp->value == labelno)
1438 lp = gfc_getmem (sizeof (gfc_st_label));
1440 lp->value = labelno;
1441 lp->defined = ST_LABEL_UNKNOWN;
1442 lp->referenced = ST_LABEL_UNKNOWN;
1445 lp->next = gfc_current_ns->st_labels;
1446 if (gfc_current_ns->st_labels)
1447 gfc_current_ns->st_labels->prev = lp;
1448 gfc_current_ns->st_labels = lp;
1454 /* Called when a statement with a statement label is about to be
1455 accepted. We add the label to the list of the current namespace,
1456 making sure it hasn't been defined previously and referenced
1460 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1464 labelno = lp->value;
1466 if (lp->defined != ST_LABEL_UNKNOWN)
1467 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1468 &lp->where, label_locus);
1471 lp->where = *label_locus;
1475 case ST_LABEL_FORMAT:
1476 if (lp->referenced == ST_LABEL_TARGET)
1477 gfc_error ("Label %d at %C already referenced as branch target",
1480 lp->defined = ST_LABEL_FORMAT;
1484 case ST_LABEL_TARGET:
1485 if (lp->referenced == ST_LABEL_FORMAT)
1486 gfc_error ("Label %d at %C already referenced as a format label",
1489 lp->defined = ST_LABEL_TARGET;
1494 lp->defined = ST_LABEL_BAD_TARGET;
1495 lp->referenced = ST_LABEL_BAD_TARGET;
1501 /* Reference a label. Given a label and its type, see if that
1502 reference is consistent with what is known about that label,
1503 updating the unknown state. Returns FAILURE if something goes
1507 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1509 gfc_sl_type label_type;
1516 labelno = lp->value;
1518 if (lp->defined != ST_LABEL_UNKNOWN)
1519 label_type = lp->defined;
1522 label_type = lp->referenced;
1523 lp->where = gfc_current_locus;
1526 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1528 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1533 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1534 && type == ST_LABEL_FORMAT)
1536 gfc_error ("Label %d at %C previously used as branch target", labelno);
1541 lp->referenced = type;
1549 /************** Symbol table management subroutines ****************/
1551 /* Basic details: Fortran 95 requires a potentially unlimited number
1552 of distinct namespaces when compiling a program unit. This case
1553 occurs during a compilation of internal subprograms because all of
1554 the internal subprograms must be read before we can start
1555 generating code for the host.
1557 Given the tricky nature of the fortran grammar, we must be able to
1558 undo changes made to a symbol table if the current interpretation
1559 of a statement is found to be incorrect. Whenever a symbol is
1560 looked up, we make a copy of it and link to it. All of these
1561 symbols are kept in a singly linked list so that we can commit or
1562 undo the changes at a later time.
1564 A symtree may point to a symbol node outside of its namespace. In
1565 this case, that symbol has been used as a host associated variable
1566 at some previous time. */
1568 /* Allocate a new namespace structure. */
1571 gfc_get_namespace (gfc_namespace * parent)
1575 gfc_intrinsic_op in;
1578 ns = gfc_getmem (sizeof (gfc_namespace));
1579 ns->sym_root = NULL;
1580 ns->uop_root = NULL;
1581 ns->default_access = ACCESS_UNKNOWN;
1582 ns->parent = parent;
1584 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1585 ns->operator_access[in] = ACCESS_UNKNOWN;
1587 /* Initialize default implicit types. */
1588 for (i = 'a'; i <= 'z'; i++)
1590 ns->set_flag[i - 'a'] = 0;
1591 ts = &ns->default_type[i - 'a'];
1593 if (ns->parent != NULL)
1595 /* Copy parent settings */
1596 *ts = ns->parent->default_type[i - 'a'];
1600 if (gfc_option.flag_implicit_none != 0)
1606 if ('i' <= i && i <= 'n')
1608 ts->type = BT_INTEGER;
1609 ts->kind = gfc_default_integer_kind ();
1614 ts->kind = gfc_default_real_kind ();
1624 /* Comparison function for symtree nodes. */
1627 compare_symtree (void * _st1, void * _st2)
1629 gfc_symtree *st1, *st2;
1631 st1 = (gfc_symtree *) _st1;
1632 st2 = (gfc_symtree *) _st2;
1634 return strcmp (st1->name, st2->name);
1638 /* Allocate a new symtree node and associate it with the new symbol. */
1641 gfc_new_symtree (gfc_symtree ** root, const char *name)
1645 st = gfc_getmem (sizeof (gfc_symtree));
1646 strcpy (st->name, name);
1648 gfc_insert_bbt (root, st, compare_symtree);
1653 /* Delete a symbol from the tree. Does not free the symbol itself! */
1656 delete_symtree (gfc_symtree ** root, const char *name)
1658 gfc_symtree st, *st0;
1660 st0 = gfc_find_symtree (*root, name);
1662 strcpy (st.name, name);
1663 gfc_delete_bbt (root, &st, compare_symtree);
1669 /* Given a root symtree node and a name, try to find the symbol within
1670 the namespace. Returns NULL if the symbol is not found. */
1673 gfc_find_symtree (gfc_symtree * st, const char *name)
1679 c = strcmp (name, st->name);
1683 st = (c < 0) ? st->left : st->right;
1690 /* Given a name find a user operator node, creating it if it doesn't
1691 exist. These are much simpler than symbols because they can't be
1692 ambiguous with one another. */
1695 gfc_get_uop (const char *name)
1700 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1704 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1706 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1707 strcpy (uop->name, name);
1708 uop->access = ACCESS_UNKNOWN;
1709 uop->ns = gfc_current_ns;
1715 /* Given a name find the user operator node. Returns NULL if it does
1719 gfc_find_uop (const char *name, gfc_namespace * ns)
1724 ns = gfc_current_ns;
1726 st = gfc_find_symtree (ns->uop_root, name);
1727 return (st == NULL) ? NULL : st->n.uop;
1731 /* Remove a gfc_symbol structure and everything it points to. */
1734 gfc_free_symbol (gfc_symbol * sym)
1740 gfc_free_array_spec (sym->as);
1742 free_components (sym->components);
1744 gfc_free_expr (sym->value);
1746 gfc_free_namelist (sym->namelist);
1748 gfc_free_namespace (sym->formal_ns);
1750 gfc_free_interface (sym->generic);
1752 gfc_free_formal_arglist (sym->formal);
1758 /* Allocate and initialize a new symbol node. */
1761 gfc_new_symbol (const char *name, gfc_namespace * ns)
1765 p = gfc_getmem (sizeof (gfc_symbol));
1767 gfc_clear_ts (&p->ts);
1768 gfc_clear_attr (&p->attr);
1771 p->declared_at = gfc_current_locus;
1773 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1774 gfc_internal_error ("new_symbol(): Symbol name too long");
1776 strcpy (p->name, name);
1781 /* Generate an error if a symbol is ambiguous. */
1784 ambiguous_symbol (const char *name, gfc_symtree * st)
1787 if (st->n.sym->module[0])
1788 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1789 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1791 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1792 "from current program unit", name, st->n.sym->name);
1796 /* Search for a symbol starting in the current namespace, resorting to
1797 any parent namespaces if requested by a nonzero parent_flag.
1798 Returns nonzero if the symbol is ambiguous. */
1801 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1802 gfc_symtree ** result)
1807 ns = gfc_current_ns;
1811 st = gfc_find_symtree (ns->sym_root, name);
1817 ambiguous_symbol (name, st);
1837 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1838 gfc_symbol ** result)
1843 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1848 *result = st->n.sym;
1854 /* Save symbol with the information necessary to back it out. */
1857 save_symbol_data (gfc_symbol * sym)
1860 if (sym->new || sym->old_symbol != NULL)
1863 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1864 *(sym->old_symbol) = *sym;
1866 sym->tlink = changed_syms;
1871 /* Given a name, find a symbol, or create it if it does not exist yet
1872 in the current namespace. If the symbol is found we make sure that
1875 The integer return code indicates
1877 1 The symbol name was ambiguous
1878 2 The name meant to be established was already host associated.
1880 So if the return value is nonzero, then an error was issued. */
1883 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1888 /* This doesn't usually happen during resolution. */
1890 ns = gfc_current_ns;
1892 /* Try to find the symbol in ns. */
1893 st = gfc_find_symtree (ns->sym_root, name);
1897 /* If not there, create a new symbol. */
1898 p = gfc_new_symbol (name, ns);
1900 /* Add to the list of tentative symbols. */
1901 p->old_symbol = NULL;
1902 p->tlink = changed_syms;
1907 st = gfc_new_symtree (&ns->sym_root, name);
1914 /* Make sure the existing symbol is OK. */
1917 ambiguous_symbol (name, st);
1923 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1925 /* Symbol is from another namespace. */
1926 gfc_error ("Symbol '%s' at %C has already been host associated",
1933 /* Copy in case this symbol is changed. */
1934 save_symbol_data (p);
1943 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1949 i = gfc_get_sym_tree (name, ns, &st);
1954 *result = st->n.sym;
1961 /* Subroutine that searches for a symbol, creating it if it doesn't
1962 exist, but tries to host-associate the symbol if possible. */
1965 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1970 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1973 save_symbol_data (st->n.sym);
1979 if (gfc_current_ns->parent != NULL)
1981 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1992 return gfc_get_sym_tree (name, gfc_current_ns, result);
1997 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
2002 i = gfc_get_ha_sym_tree (name, &st);
2005 *result = st->n.sym;
2012 /* Return true if both symbols could refer to the same data object. Does
2013 not take account of aliasing due to equivalence statements. */
2016 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
2018 /* Aliasing isn't possible if the symbols have different base types. */
2019 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2022 /* Pointers can point to other pointers, target objects and allocatable
2023 objects. Two allocatable objects cannot share the same storage. */
2024 if (lsym->attr.pointer
2025 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2027 if (lsym->attr.target && rsym->attr.pointer)
2029 if (lsym->attr.allocatable && rsym->attr.pointer)
2036 /* Undoes all the changes made to symbols in the current statement.
2037 This subroutine is made simpler due to the fact that attributes are
2038 never removed once added. */
2041 gfc_undo_symbols (void)
2043 gfc_symbol *p, *q, *old;
2045 for (p = changed_syms; p; p = q)
2051 /* Symbol was new. */
2052 delete_symtree (&p->ns->sym_root, p->name);
2056 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2058 gfc_free_symbol (p);
2062 /* Restore previous state of symbol. Just copy simple stuff. */
2064 old = p->old_symbol;
2066 p->ts.type = old->ts.type;
2067 p->ts.kind = old->ts.kind;
2069 p->attr = old->attr;
2071 if (p->value != old->value)
2073 gfc_free_expr (old->value);
2077 if (p->as != old->as)
2080 gfc_free_array_spec (p->as);
2084 p->generic = old->generic;
2085 p->component_access = old->component_access;
2087 if (p->namelist != NULL && old->namelist == NULL)
2089 gfc_free_namelist (p->namelist);
2095 if (p->namelist_tail != old->namelist_tail)
2097 gfc_free_namelist (old->namelist_tail);
2098 old->namelist_tail->next = NULL;
2102 p->namelist_tail = old->namelist_tail;
2104 if (p->formal != old->formal)
2106 gfc_free_formal_arglist (p->formal);
2107 p->formal = old->formal;
2110 gfc_free (p->old_symbol);
2111 p->old_symbol = NULL;
2115 changed_syms = NULL;
2119 /* Makes the changes made in the current statement permanent-- gets
2120 rid of undo information. */
2123 gfc_commit_symbols (void)
2127 for (p = changed_syms; p; p = q)
2134 if (p->old_symbol != NULL)
2136 gfc_free (p->old_symbol);
2137 p->old_symbol = NULL;
2141 changed_syms = NULL;
2145 /* Recursive function that deletes an entire tree and all the common
2146 head structures it points to. */
2149 free_common_tree (gfc_symtree * common_tree)
2151 if (common_tree == NULL)
2154 free_common_tree (common_tree->left);
2155 free_common_tree (common_tree->right);
2157 gfc_free (common_tree);
2161 /* Recursive function that deletes an entire tree and all the user
2162 operator nodes that it contains. */
2165 free_uop_tree (gfc_symtree * uop_tree)
2168 if (uop_tree == NULL)
2171 free_uop_tree (uop_tree->left);
2172 free_uop_tree (uop_tree->right);
2174 gfc_free_interface (uop_tree->n.uop->operator);
2176 gfc_free (uop_tree->n.uop);
2177 gfc_free (uop_tree);
2181 /* Recursive function that deletes an entire tree and all the symbols
2182 that it contains. */
2185 free_sym_tree (gfc_symtree * sym_tree)
2190 if (sym_tree == NULL)
2193 free_sym_tree (sym_tree->left);
2194 free_sym_tree (sym_tree->right);
2196 sym = sym_tree->n.sym;
2200 gfc_internal_error ("free_sym_tree(): Negative refs");
2202 if (sym->formal_ns != NULL && sym->refs == 1)
2204 /* As formal_ns contains a reference to sym, delete formal_ns just
2205 before the deletion of sym. */
2206 ns = sym->formal_ns;
2207 sym->formal_ns = NULL;
2208 gfc_free_namespace (ns);
2210 else if (sym->refs == 0)
2212 /* Go ahead and delete the symbol. */
2213 gfc_free_symbol (sym);
2216 gfc_free (sym_tree);
2220 /* Free a namespace structure and everything below it. Interface
2221 lists associated with intrinsic operators are not freed. These are
2222 taken care of when a specific name is freed. */
2225 gfc_free_namespace (gfc_namespace * ns)
2227 gfc_charlen *cl, *cl2;
2228 gfc_namespace *p, *q;
2237 assert (ns->refs == 0);
2239 gfc_free_statements (ns->code);
2241 free_sym_tree (ns->sym_root);
2242 free_uop_tree (ns->uop_root);
2243 free_common_tree (ns->common_root);
2245 for (cl = ns->cl_list; cl; cl = cl2)
2248 gfc_free_expr (cl->length);
2252 free_st_labels (ns->st_labels);
2254 gfc_free_equiv (ns->equiv);
2256 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2257 gfc_free_interface (ns->operator[i]);
2259 gfc_free_data (ns->data);
2263 /* Recursively free any contained namespaces. */
2269 gfc_free_namespace (q);
2275 gfc_symbol_init_2 (void)
2278 gfc_current_ns = gfc_get_namespace (NULL);
2283 gfc_symbol_done_2 (void)
2286 gfc_free_namespace (gfc_current_ns);
2287 gfc_current_ns = NULL;
2291 /* Clear mark bits from symbol nodes associated with a symtree node. */
2294 clear_sym_mark (gfc_symtree * st)
2297 st->n.sym->mark = 0;
2301 /* Recursively traverse the symtree nodes. */
2304 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2310 gfc_traverse_symtree (st->left, func);
2311 gfc_traverse_symtree (st->right, func);
2316 /* Recursive namespace traversal function. */
2319 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2325 if (st->n.sym->mark == 0)
2326 (*func) (st->n.sym);
2327 st->n.sym->mark = 1;
2329 traverse_ns (st->left, func);
2330 traverse_ns (st->right, func);
2334 /* Call a given function for all symbols in the namespace. We take
2335 care that each gfc_symbol node is called exactly once. */
2338 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2341 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2343 traverse_ns (ns->sym_root, func);
2347 /* Given a symbol, mark it as SAVEd if it is allowed. */
2350 save_symbol (gfc_symbol * sym)
2353 if (sym->attr.use_assoc)
2356 if (sym->attr.in_common
2358 || sym->attr.flavor != FL_VARIABLE)
2361 gfc_add_save (&sym->attr, &sym->declared_at);
2365 /* Mark those symbols which can be SAVEd as such. */
2368 gfc_save_all (gfc_namespace * ns)
2371 gfc_traverse_ns (ns, save_symbol);
2376 /* Make sure that no changes to symbols are pending. */
2379 gfc_symbol_state(void) {
2381 if (changed_syms != NULL)
2382 gfc_internal_error("Symbol changes still pending!");
2387 /************** Global symbol handling ************/
2390 /* Search a tree for the global symbol. */
2393 gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
2399 if (strcmp (symbol->name, name) == 0)
2402 s = gfc_find_gsymbol (symbol->left, name);
2406 s = gfc_find_gsymbol (symbol->right, name);
2414 /* Compare two global symbols. Used for managing the BB tree. */
2417 gsym_compare (void * _s1, void * _s2)
2419 gfc_gsymbol *s1, *s2;
2421 s1 = (gfc_gsymbol *)_s1;
2422 s2 = (gfc_gsymbol *)_s2;
2423 return strcmp(s1->name, s2->name);
2427 /* Get a global symbol, creating it if it doesn't exist. */
2430 gfc_get_gsymbol (char *name)
2434 s = gfc_find_gsymbol (gfc_gsym_root, name);
2438 s = gfc_getmem (sizeof (gfc_gsymbol));
2439 s->type = GSYM_UNKNOWN;
2440 strcpy (s->name, name);
2442 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);