1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
37 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
38 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
39 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
43 const mstring procedures[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
46 minit ("MODULE-PROC", PROC_MODULE),
47 minit ("INTERNAL-PROC", PROC_INTERNAL),
48 minit ("DUMMY-PROC", PROC_DUMMY),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
55 const mstring intents[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
58 minit ("IN", INTENT_IN),
59 minit ("OUT", INTENT_OUT),
60 minit ("INOUT", INTENT_INOUT),
64 const mstring access_types[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
67 minit ("PUBLIC", ACCESS_PUBLIC),
68 minit ("PRIVATE", ACCESS_PRIVATE),
72 const mstring ifsrc_types[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN),
75 minit ("DECL", IFSRC_DECL),
76 minit ("BODY", IFSRC_IFBODY),
77 minit ("USAGE", IFSRC_USAGE)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order = 1;
87 gfc_namespace *gfc_current_ns;
89 gfc_gsymbol *gfc_gsym_root = NULL;
91 static gfc_symbol *changed_syms = NULL;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag[GFC_LETTERS];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 for (i = 0; i < GFC_LETTERS; i++)
111 gfc_clear_ts (&gfc_current_ns->default_type[i]);
112 gfc_current_ns->set_flag[i] = 1;
117 /* Reset the implicit range flags. */
120 gfc_clear_new_implicit (void)
124 for (i = 0; i < GFC_LETTERS; i++)
129 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
132 gfc_add_new_implicit_range (int c1, int c2)
139 for (i = c1; i <= c2; i++)
143 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
155 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
156 the new implicit types back into the existing types will work. */
159 gfc_merge_new_implicit (gfc_typespec * ts)
163 for (i = 0; i < GFC_LETTERS; i++)
168 if (gfc_current_ns->set_flag[i])
170 gfc_error ("Letter %c already has an IMPLICIT type at %C",
174 gfc_current_ns->default_type[i] = *ts;
175 gfc_current_ns->set_flag[i] = 1;
182 /* Given a symbol, return a pointer to the typespec for its default type. */
185 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
189 letter = sym->name[0];
190 if (letter < 'a' || letter > 'z')
191 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
196 return &ns->default_type[letter - 'a'];
200 /* Given a pointer to a symbol, set its type according to the first
201 letter of its name. Fails if the letter in question has no default
205 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
209 if (sym->ts.type != BT_UNKNOWN)
210 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
212 ts = gfc_get_default_type (sym, ns);
214 if (ts->type == BT_UNKNOWN)
216 if (error_flag && !sym->attr.untyped)
218 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
219 sym->name, &sym->declared_at);
220 sym->attr.untyped = 1; /* Ensure we only give an error once. */
227 sym->attr.implicit_type = 1;
233 /******************** Symbol attribute stuff *********************/
235 /* This is a generic conflict-checker. We do this to avoid having a
236 single conflict in two places. */
238 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
239 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
242 check_conflict (symbol_attribute * attr, const char * name, locus * where)
244 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
245 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
246 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
247 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
248 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
249 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
250 *function = "FUNCTION", *subroutine = "SUBROUTINE",
251 *dimension = "DIMENSION";
256 where = &gfc_current_locus;
258 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
265 /* Check for attributes not allowed in a BLOCK DATA. */
266 if (gfc_current_state () == COMP_BLOCK_DATA)
270 if (attr->allocatable)
276 if (attr->access == ACCESS_PRIVATE)
278 if (attr->access == ACCESS_PUBLIC)
280 if (attr->intent != INTENT_UNKNOWN)
286 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
293 conf (pointer, target);
294 conf (pointer, external);
295 conf (pointer, intrinsic);
296 conf (target, external);
297 conf (target, intrinsic);
298 conf (external, dimension); /* See Fortran 95's R504. */
300 conf (external, intrinsic);
301 conf (allocatable, pointer);
302 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
303 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
304 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
305 conf (elemental, recursive);
307 conf (in_common, dummy);
308 conf (in_common, allocatable);
309 conf (in_common, result);
310 conf (dummy, result);
312 conf (in_namelist, pointer);
313 conf (in_namelist, allocatable);
315 conf (entry, result);
317 conf (function, subroutine);
319 a1 = gfc_code2string (flavors, attr->flavor);
321 if (attr->in_namelist
322 && attr->flavor != FL_VARIABLE
323 && attr->flavor != FL_UNKNOWN)
330 switch (attr->flavor)
357 if (attr->subroutine)
370 case PROC_ST_FUNCTION:
403 if (attr->intent != INTENT_UNKNOWN)
432 gfc_error ("%s attribute conflicts with %s attribute at %L",
435 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
436 a1, a2, name, where);
445 /* Mark a symbol as referenced. */
448 gfc_set_sym_referenced (gfc_symbol * sym)
450 if (sym->attr.referenced)
453 sym->attr.referenced = 1;
455 /* Remember which order dummy variables are accessed in. */
457 sym->dummy_order = next_dummy_order++;
461 /* Common subroutine called by attribute changing subroutines in order
462 to prevent them from changing a symbol that has been
463 use-associated. Returns zero if it is OK to change the symbol,
467 check_used (symbol_attribute * attr, const char * name, locus * where)
470 if (attr->use_assoc == 0)
474 where = &gfc_current_locus;
477 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
480 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
487 /* Used to prevent changing the attributes of a symbol after it has been
488 used. This check is only done for dummy variables as only these can be
489 used in specification expressions. Applying this to all symbols causes
490 an error when we reach the body of a contained function. */
493 check_done (symbol_attribute * attr, locus * where)
496 if (!(attr->dummy && attr->referenced))
500 where = &gfc_current_locus;
502 gfc_error ("Cannot change attributes of symbol at %L"
503 " after it has been used", where);
509 /* Generate an error because of a duplicate attribute. */
512 duplicate_attr (const char *attr, locus * where)
516 where = &gfc_current_locus;
518 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
523 gfc_add_allocatable (symbol_attribute * attr, locus * where)
526 if (check_used (attr, NULL, where) || check_done (attr, where))
529 if (attr->allocatable)
531 duplicate_attr ("ALLOCATABLE", where);
535 attr->allocatable = 1;
536 return check_conflict (attr, NULL, where);
541 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
544 if (check_used (attr, name, where) || check_done (attr, where))
549 duplicate_attr ("DIMENSION", where);
554 return check_conflict (attr, name, where);
559 gfc_add_external (symbol_attribute * attr, locus * where)
562 if (check_used (attr, NULL, where) || check_done (attr, where))
567 duplicate_attr ("EXTERNAL", where);
573 return check_conflict (attr, NULL, where);
578 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
581 if (check_used (attr, NULL, where) || check_done (attr, where))
586 duplicate_attr ("INTRINSIC", where);
592 return check_conflict (attr, NULL, where);
597 gfc_add_optional (symbol_attribute * attr, locus * where)
600 if (check_used (attr, NULL, where) || check_done (attr, where))
605 duplicate_attr ("OPTIONAL", where);
610 return check_conflict (attr, NULL, where);
615 gfc_add_pointer (symbol_attribute * attr, locus * where)
618 if (check_used (attr, NULL, where) || check_done (attr, where))
622 return check_conflict (attr, NULL, where);
627 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
630 if (check_used (attr, name, where) || check_done (attr, where))
634 return check_conflict (attr, name, where);
639 gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
642 if (check_used (attr, name, where))
648 ("SAVE attribute at %L cannot be specified in a PURE procedure",
655 duplicate_attr ("SAVE", where);
660 return check_conflict (attr, name, where);
665 gfc_add_target (symbol_attribute * attr, locus * where)
668 if (check_used (attr, NULL, where) || check_done (attr, where))
673 duplicate_attr ("TARGET", where);
678 return check_conflict (attr, NULL, where);
683 gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
686 if (check_used (attr, name, where))
689 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
691 return check_conflict (attr, name, where);
696 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
699 if (check_used (attr, name, where) || check_done (attr, where))
702 /* Duplicate attribute already checked for. */
704 if (check_conflict (attr, name, where) == FAILURE)
707 if (attr->flavor == FL_VARIABLE)
710 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
715 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
718 if (check_used (attr, name, where))
722 return check_conflict (attr, name, where);
727 gfc_add_in_namelist (symbol_attribute * attr, const char *name,
731 attr->in_namelist = 1;
732 return check_conflict (attr, name, where);
737 gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
740 if (check_used (attr, name, where))
744 return check_conflict (attr, name, where);
749 gfc_add_elemental (symbol_attribute * attr, locus * where)
752 if (check_used (attr, NULL, where) || check_done (attr, where))
756 return check_conflict (attr, NULL, where);
761 gfc_add_pure (symbol_attribute * attr, locus * where)
764 if (check_used (attr, NULL, where) || check_done (attr, where))
768 return check_conflict (attr, NULL, where);
773 gfc_add_recursive (symbol_attribute * attr, locus * where)
776 if (check_used (attr, NULL, where) || check_done (attr, where))
780 return check_conflict (attr, NULL, where);
785 gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
788 if (check_used (attr, name, where))
793 duplicate_attr ("ENTRY", where);
798 return check_conflict (attr, name, where);
803 gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
806 if (attr->flavor != FL_PROCEDURE
807 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
811 return check_conflict (attr, name, where);
816 gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
819 if (attr->flavor != FL_PROCEDURE
820 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
823 attr->subroutine = 1;
824 return check_conflict (attr, name, where);
829 gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
832 if (attr->flavor != FL_PROCEDURE
833 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
837 return check_conflict (attr, name, where);
841 /* Flavors are special because some flavors are not what Fortran
842 considers attributes and can be reaffirmed multiple times. */
845 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
849 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
850 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
851 || f == FL_NAMELIST) && check_used (attr, name, where))
854 if (attr->flavor == f && f == FL_VARIABLE)
857 if (attr->flavor != FL_UNKNOWN)
860 where = &gfc_current_locus;
862 gfc_error ("%s attribute conflicts with %s attribute at %L",
863 gfc_code2string (flavors, attr->flavor),
864 gfc_code2string (flavors, f), where);
871 return check_conflict (attr, name, where);
876 gfc_add_procedure (symbol_attribute * attr, procedure_type t,
877 const char *name, locus * where)
880 if (check_used (attr, name, where) || check_done (attr, where))
883 if (attr->flavor != FL_PROCEDURE
884 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
888 where = &gfc_current_locus;
890 if (attr->proc != PROC_UNKNOWN)
892 gfc_error ("%s procedure at %L is already %s %s procedure",
893 gfc_code2string (procedures, t), where,
894 gfc_article (gfc_code2string (procedures, attr->proc)),
895 gfc_code2string (procedures, attr->proc));
902 /* Statement functions are always scalar and functions. */
903 if (t == PROC_ST_FUNCTION
904 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
908 return check_conflict (attr, name, where);
913 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
916 if (check_used (attr, NULL, where))
919 if (attr->intent == INTENT_UNKNOWN)
921 attr->intent = intent;
922 return check_conflict (attr, NULL, where);
926 where = &gfc_current_locus;
928 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
929 gfc_intent_string (attr->intent),
930 gfc_intent_string (intent), where);
936 /* No checks for use-association in public and private statements. */
939 gfc_add_access (symbol_attribute * attr, gfc_access access,
940 const char *name, locus * where)
943 if (attr->access == ACCESS_UNKNOWN)
945 attr->access = access;
946 return check_conflict (attr, name, where);
950 where = &gfc_current_locus;
951 gfc_error ("ACCESS specification at %L was already specified", where);
958 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
959 gfc_formal_arglist * formal, locus * where)
962 if (check_used (&sym->attr, sym->name, where))
966 where = &gfc_current_locus;
968 if (sym->attr.if_source != IFSRC_UNKNOWN
969 && sym->attr.if_source != IFSRC_DECL)
971 gfc_error ("Symbol '%s' at %L already has an explicit interface",
976 sym->formal = formal;
977 sym->attr.if_source = source;
983 /* Add a type to a symbol. */
986 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
990 /* TODO: This is legal if it is reaffirming an implicit type.
991 if (check_done (&sym->attr, where))
995 where = &gfc_current_locus;
997 if (sym->ts.type != BT_UNKNOWN)
999 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1000 where, gfc_basic_typename (sym->ts.type));
1004 flavor = sym->attr.flavor;
1006 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1007 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1008 && sym->attr.subroutine)
1009 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1011 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1020 /* Clears all attributes. */
1023 gfc_clear_attr (symbol_attribute * attr)
1025 memset (attr, 0, sizeof(symbol_attribute));
1029 /* Check for missing attributes in the new symbol. Currently does
1030 nothing, but it's not clear that it is unnecessary yet. */
1033 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1034 locus * where ATTRIBUTE_UNUSED)
1041 /* Copy an attribute to a symbol attribute, bit by bit. Some
1042 attributes have a lot of side-effects but cannot be present given
1043 where we are called from, so we ignore some bits. */
1046 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1049 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1052 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1054 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1056 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1058 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1060 if (src->target && gfc_add_target (dest, where) == FAILURE)
1062 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1064 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1069 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1072 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1075 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1077 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1079 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1082 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1084 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1086 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1088 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1091 if (src->flavor != FL_UNKNOWN
1092 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1095 if (src->intent != INTENT_UNKNOWN
1096 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1099 if (src->access != ACCESS_UNKNOWN
1100 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1103 if (gfc_missing_attr (dest, where) == FAILURE)
1106 /* The subroutines that set these bits also cause flavors to be set,
1107 and that has already happened in the original, so don't let it
1112 dest->intrinsic = 1;
1121 /************** Component name management ************/
1123 /* Component names of a derived type form their own little namespaces
1124 that are separate from all other spaces. The space is composed of
1125 a singly linked list of gfc_component structures whose head is
1126 located in the parent symbol. */
1129 /* Add a component name to a symbol. The call fails if the name is
1130 already present. On success, the component pointer is modified to
1131 point to the additional component structure. */
1134 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1136 gfc_component *p, *tail;
1140 for (p = sym->components; p; p = p->next)
1142 if (strcmp (p->name, name) == 0)
1144 gfc_error ("Component '%s' at %C already declared at %L",
1152 /* Allocate a new component. */
1153 p = gfc_get_component ();
1156 sym->components = p;
1160 p->name = gfc_get_string (name);
1161 p->loc = gfc_current_locus;
1168 /* Recursive function to switch derived types of all symbol in a
1172 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1180 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1181 sym->ts.derived = to;
1183 switch_types (st->left, from, to);
1184 switch_types (st->right, from, to);
1188 /* This subroutine is called when a derived type is used in order to
1189 make the final determination about which version to use. The
1190 standard requires that a type be defined before it is 'used', but
1191 such types can appear in IMPLICIT statements before the actual
1192 definition. 'Using' in this context means declaring a variable to
1193 be that type or using the type constructor.
1195 If a type is used and the components haven't been defined, then we
1196 have to have a derived type in a parent unit. We find the node in
1197 the other namespace and point the symtree node in this namespace to
1198 that node. Further reference to this name point to the correct
1199 node. If we can't find the node in a parent namespace, then we have
1202 This subroutine takes a pointer to a symbol node and returns a
1203 pointer to the translated node or NULL for an error. Usually there
1204 is no translation and we return the node we were passed. */
1207 gfc_use_derived (gfc_symbol * sym)
1214 if (sym->components != NULL)
1215 return sym; /* Already defined. */
1217 if (sym->ns->parent == NULL)
1220 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1222 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1226 if (s == NULL || s->attr.flavor != FL_DERIVED)
1229 /* Get rid of symbol sym, translating all references to s. */
1230 for (i = 0; i < GFC_LETTERS; i++)
1232 t = &sym->ns->default_type[i];
1233 if (t->derived == sym)
1237 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1242 /* Unlink from list of modified symbols. */
1243 if (changed_syms == sym)
1244 changed_syms = sym->tlink;
1246 for (p = changed_syms; p; p = p->tlink)
1247 if (p->tlink == sym)
1249 p->tlink = sym->tlink;
1253 switch_types (sym->ns->sym_root, sym, s);
1255 /* TODO: Also have to replace sym -> s in other lists like
1256 namelists, common lists and interface lists. */
1257 gfc_free_symbol (sym);
1262 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1268 /* Given a derived type node and a component name, try to locate the
1269 component structure. Returns the NULL pointer if the component is
1270 not found or the components are private. */
1273 gfc_find_component (gfc_symbol * sym, const char *name)
1280 sym = gfc_use_derived (sym);
1285 for (p = sym->components; p; p = p->next)
1286 if (strcmp (p->name, name) == 0)
1290 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1294 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1296 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1306 /* Given a symbol, free all of the component structures and everything
1310 free_components (gfc_component * p)
1318 gfc_free_array_spec (p->as);
1319 gfc_free_expr (p->initializer);
1326 /* Set component attributes from a standard symbol attribute
1330 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1333 c->dimension = attr->dimension;
1334 c->pointer = attr->pointer;
1338 /* Get a standard symbol attribute structure given the component
1342 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1345 gfc_clear_attr (attr);
1346 attr->dimension = c->dimension;
1347 attr->pointer = c->pointer;
1351 /******************** Statement label management ********************/
1353 /* Free a single gfc_st_label structure, making sure the list is not
1354 messed up. This function is called only when some parse error
1358 gfc_free_st_label (gfc_st_label * l)
1365 (l->prev->next = l->next);
1368 (l->next->prev = l->prev);
1370 if (l->format != NULL)
1371 gfc_free_expr (l->format);
1375 /* Free a whole list of gfc_st_label structures. */
1378 free_st_labels (gfc_st_label * l1)
1385 if (l1->format != NULL)
1386 gfc_free_expr (l1->format);
1392 /* Given a label number, search for and return a pointer to the label
1393 structure, creating it if it does not exist. */
1396 gfc_get_st_label (int labelno)
1400 /* First see if the label is already in this namespace. */
1401 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1402 if (lp->value == labelno)
1407 lp = gfc_getmem (sizeof (gfc_st_label));
1409 lp->value = labelno;
1410 lp->defined = ST_LABEL_UNKNOWN;
1411 lp->referenced = ST_LABEL_UNKNOWN;
1414 lp->next = gfc_current_ns->st_labels;
1415 if (gfc_current_ns->st_labels)
1416 gfc_current_ns->st_labels->prev = lp;
1417 gfc_current_ns->st_labels = lp;
1423 /* Called when a statement with a statement label is about to be
1424 accepted. We add the label to the list of the current namespace,
1425 making sure it hasn't been defined previously and referenced
1429 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1433 labelno = lp->value;
1435 if (lp->defined != ST_LABEL_UNKNOWN)
1436 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1437 &lp->where, label_locus);
1440 lp->where = *label_locus;
1444 case ST_LABEL_FORMAT:
1445 if (lp->referenced == ST_LABEL_TARGET)
1446 gfc_error ("Label %d at %C already referenced as branch target",
1449 lp->defined = ST_LABEL_FORMAT;
1453 case ST_LABEL_TARGET:
1454 if (lp->referenced == ST_LABEL_FORMAT)
1455 gfc_error ("Label %d at %C already referenced as a format label",
1458 lp->defined = ST_LABEL_TARGET;
1463 lp->defined = ST_LABEL_BAD_TARGET;
1464 lp->referenced = ST_LABEL_BAD_TARGET;
1470 /* Reference a label. Given a label and its type, see if that
1471 reference is consistent with what is known about that label,
1472 updating the unknown state. Returns FAILURE if something goes
1476 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1478 gfc_sl_type label_type;
1485 labelno = lp->value;
1487 if (lp->defined != ST_LABEL_UNKNOWN)
1488 label_type = lp->defined;
1491 label_type = lp->referenced;
1492 lp->where = gfc_current_locus;
1495 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1497 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1502 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1503 && type == ST_LABEL_FORMAT)
1505 gfc_error ("Label %d at %C previously used as branch target", labelno);
1510 lp->referenced = type;
1518 /************** Symbol table management subroutines ****************/
1520 /* Basic details: Fortran 95 requires a potentially unlimited number
1521 of distinct namespaces when compiling a program unit. This case
1522 occurs during a compilation of internal subprograms because all of
1523 the internal subprograms must be read before we can start
1524 generating code for the host.
1526 Given the tricky nature of the Fortran grammar, we must be able to
1527 undo changes made to a symbol table if the current interpretation
1528 of a statement is found to be incorrect. Whenever a symbol is
1529 looked up, we make a copy of it and link to it. All of these
1530 symbols are kept in a singly linked list so that we can commit or
1531 undo the changes at a later time.
1533 A symtree may point to a symbol node outside of its namespace. In
1534 this case, that symbol has been used as a host associated variable
1535 at some previous time. */
1537 /* Allocate a new namespace structure. Copies the implicit types from
1538 PARENT if PARENT_TYPES is set. */
1541 gfc_get_namespace (gfc_namespace * parent, int parent_types)
1545 gfc_intrinsic_op in;
1548 ns = gfc_getmem (sizeof (gfc_namespace));
1549 ns->sym_root = NULL;
1550 ns->uop_root = NULL;
1551 ns->default_access = ACCESS_UNKNOWN;
1552 ns->parent = parent;
1554 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1555 ns->operator_access[in] = ACCESS_UNKNOWN;
1557 /* Initialize default implicit types. */
1558 for (i = 'a'; i <= 'z'; i++)
1560 ns->set_flag[i - 'a'] = 0;
1561 ts = &ns->default_type[i - 'a'];
1563 if (parent_types && ns->parent != NULL)
1565 /* Copy parent settings */
1566 *ts = ns->parent->default_type[i - 'a'];
1570 if (gfc_option.flag_implicit_none != 0)
1576 if ('i' <= i && i <= 'n')
1578 ts->type = BT_INTEGER;
1579 ts->kind = gfc_default_integer_kind;
1584 ts->kind = gfc_default_real_kind;
1594 /* Comparison function for symtree nodes. */
1597 compare_symtree (void * _st1, void * _st2)
1599 gfc_symtree *st1, *st2;
1601 st1 = (gfc_symtree *) _st1;
1602 st2 = (gfc_symtree *) _st2;
1604 return strcmp (st1->name, st2->name);
1608 /* Allocate a new symtree node and associate it with the new symbol. */
1611 gfc_new_symtree (gfc_symtree ** root, const char *name)
1615 st = gfc_getmem (sizeof (gfc_symtree));
1616 st->name = gfc_get_string (name);
1618 gfc_insert_bbt (root, st, compare_symtree);
1623 /* Delete a symbol from the tree. Does not free the symbol itself! */
1626 delete_symtree (gfc_symtree ** root, const char *name)
1628 gfc_symtree st, *st0;
1630 st0 = gfc_find_symtree (*root, name);
1632 st.name = gfc_get_string (name);
1633 gfc_delete_bbt (root, &st, compare_symtree);
1639 /* Given a root symtree node and a name, try to find the symbol within
1640 the namespace. Returns NULL if the symbol is not found. */
1643 gfc_find_symtree (gfc_symtree * st, const char *name)
1649 c = strcmp (name, st->name);
1653 st = (c < 0) ? st->left : st->right;
1660 /* Given a name find a user operator node, creating it if it doesn't
1661 exist. These are much simpler than symbols because they can't be
1662 ambiguous with one another. */
1665 gfc_get_uop (const char *name)
1670 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1674 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1676 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1677 uop->name = gfc_get_string (name);
1678 uop->access = ACCESS_UNKNOWN;
1679 uop->ns = gfc_current_ns;
1685 /* Given a name find the user operator node. Returns NULL if it does
1689 gfc_find_uop (const char *name, gfc_namespace * ns)
1694 ns = gfc_current_ns;
1696 st = gfc_find_symtree (ns->uop_root, name);
1697 return (st == NULL) ? NULL : st->n.uop;
1701 /* Remove a gfc_symbol structure and everything it points to. */
1704 gfc_free_symbol (gfc_symbol * sym)
1710 gfc_free_array_spec (sym->as);
1712 free_components (sym->components);
1714 gfc_free_expr (sym->value);
1716 gfc_free_namelist (sym->namelist);
1718 gfc_free_namespace (sym->formal_ns);
1720 gfc_free_interface (sym->generic);
1722 gfc_free_formal_arglist (sym->formal);
1728 /* Allocate and initialize a new symbol node. */
1731 gfc_new_symbol (const char *name, gfc_namespace * ns)
1735 p = gfc_getmem (sizeof (gfc_symbol));
1737 gfc_clear_ts (&p->ts);
1738 gfc_clear_attr (&p->attr);
1741 p->declared_at = gfc_current_locus;
1743 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1744 gfc_internal_error ("new_symbol(): Symbol name too long");
1746 p->name = gfc_get_string (name);
1751 /* Generate an error if a symbol is ambiguous. */
1754 ambiguous_symbol (const char *name, gfc_symtree * st)
1757 if (st->n.sym->module)
1758 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1759 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1761 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1762 "from current program unit", name, st->n.sym->name);
1766 /* Search for a symtree starting in the current namespace, resorting to
1767 any parent namespaces if requested by a nonzero parent_flag.
1768 Returns nonzero if the name is ambiguous. */
1771 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1772 gfc_symtree ** result)
1777 ns = gfc_current_ns;
1781 st = gfc_find_symtree (ns->sym_root, name);
1787 ambiguous_symbol (name, st);
1806 /* Same, but returns the symbol instead. */
1809 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1810 gfc_symbol ** result)
1815 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1820 *result = st->n.sym;
1826 /* Save symbol with the information necessary to back it out. */
1829 save_symbol_data (gfc_symbol * sym)
1832 if (sym->new || sym->old_symbol != NULL)
1835 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1836 *(sym->old_symbol) = *sym;
1838 sym->tlink = changed_syms;
1843 /* Given a name, find a symbol, or create it if it does not exist yet
1844 in the current namespace. If the symbol is found we make sure that
1847 The integer return code indicates
1849 1 The symbol name was ambiguous
1850 2 The name meant to be established was already host associated.
1852 So if the return value is nonzero, then an error was issued. */
1855 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1860 /* This doesn't usually happen during resolution. */
1862 ns = gfc_current_ns;
1864 /* Try to find the symbol in ns. */
1865 st = gfc_find_symtree (ns->sym_root, name);
1869 /* If not there, create a new symbol. */
1870 p = gfc_new_symbol (name, ns);
1872 /* Add to the list of tentative symbols. */
1873 p->old_symbol = NULL;
1874 p->tlink = changed_syms;
1879 st = gfc_new_symtree (&ns->sym_root, name);
1886 /* Make sure the existing symbol is OK. */
1889 ambiguous_symbol (name, st);
1895 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1897 /* Symbol is from another namespace. */
1898 gfc_error ("Symbol '%s' at %C has already been host associated",
1905 /* Copy in case this symbol is changed. */
1906 save_symbol_data (p);
1915 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1921 i = gfc_get_sym_tree (name, ns, &st);
1926 *result = st->n.sym;
1933 /* Subroutine that searches for a symbol, creating it if it doesn't
1934 exist, but tries to host-associate the symbol if possible. */
1937 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1942 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1945 save_symbol_data (st->n.sym);
1951 if (gfc_current_ns->parent != NULL)
1953 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1964 return gfc_get_sym_tree (name, gfc_current_ns, result);
1969 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
1974 i = gfc_get_ha_sym_tree (name, &st);
1977 *result = st->n.sym;
1984 /* Return true if both symbols could refer to the same data object. Does
1985 not take account of aliasing due to equivalence statements. */
1988 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
1990 /* Aliasing isn't possible if the symbols have different base types. */
1991 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
1994 /* Pointers can point to other pointers, target objects and allocatable
1995 objects. Two allocatable objects cannot share the same storage. */
1996 if (lsym->attr.pointer
1997 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
1999 if (lsym->attr.target && rsym->attr.pointer)
2001 if (lsym->attr.allocatable && rsym->attr.pointer)
2008 /* Undoes all the changes made to symbols in the current statement.
2009 This subroutine is made simpler due to the fact that attributes are
2010 never removed once added. */
2013 gfc_undo_symbols (void)
2015 gfc_symbol *p, *q, *old;
2017 for (p = changed_syms; p; p = q)
2023 /* Symbol was new. */
2024 delete_symtree (&p->ns->sym_root, p->name);
2028 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2030 gfc_free_symbol (p);
2034 /* Restore previous state of symbol. Just copy simple stuff. */
2036 old = p->old_symbol;
2038 p->ts.type = old->ts.type;
2039 p->ts.kind = old->ts.kind;
2041 p->attr = old->attr;
2043 if (p->value != old->value)
2045 gfc_free_expr (old->value);
2049 if (p->as != old->as)
2052 gfc_free_array_spec (p->as);
2056 p->generic = old->generic;
2057 p->component_access = old->component_access;
2059 if (p->namelist != NULL && old->namelist == NULL)
2061 gfc_free_namelist (p->namelist);
2067 if (p->namelist_tail != old->namelist_tail)
2069 gfc_free_namelist (old->namelist_tail);
2070 old->namelist_tail->next = NULL;
2074 p->namelist_tail = old->namelist_tail;
2076 if (p->formal != old->formal)
2078 gfc_free_formal_arglist (p->formal);
2079 p->formal = old->formal;
2082 gfc_free (p->old_symbol);
2083 p->old_symbol = NULL;
2087 changed_syms = NULL;
2091 /* Makes the changes made in the current statement permanent-- gets
2092 rid of undo information. */
2095 gfc_commit_symbols (void)
2099 for (p = changed_syms; p; p = q)
2106 if (p->old_symbol != NULL)
2108 gfc_free (p->old_symbol);
2109 p->old_symbol = NULL;
2113 changed_syms = NULL;
2117 /* Recursive function that deletes an entire tree and all the common
2118 head structures it points to. */
2121 free_common_tree (gfc_symtree * common_tree)
2123 if (common_tree == NULL)
2126 free_common_tree (common_tree->left);
2127 free_common_tree (common_tree->right);
2129 gfc_free (common_tree);
2133 /* Recursive function that deletes an entire tree and all the user
2134 operator nodes that it contains. */
2137 free_uop_tree (gfc_symtree * uop_tree)
2140 if (uop_tree == NULL)
2143 free_uop_tree (uop_tree->left);
2144 free_uop_tree (uop_tree->right);
2146 gfc_free_interface (uop_tree->n.uop->operator);
2148 gfc_free (uop_tree->n.uop);
2149 gfc_free (uop_tree);
2153 /* Recursive function that deletes an entire tree and all the symbols
2154 that it contains. */
2157 free_sym_tree (gfc_symtree * sym_tree)
2162 if (sym_tree == NULL)
2165 free_sym_tree (sym_tree->left);
2166 free_sym_tree (sym_tree->right);
2168 sym = sym_tree->n.sym;
2172 gfc_internal_error ("free_sym_tree(): Negative refs");
2174 if (sym->formal_ns != NULL && sym->refs == 1)
2176 /* As formal_ns contains a reference to sym, delete formal_ns just
2177 before the deletion of sym. */
2178 ns = sym->formal_ns;
2179 sym->formal_ns = NULL;
2180 gfc_free_namespace (ns);
2182 else if (sym->refs == 0)
2184 /* Go ahead and delete the symbol. */
2185 gfc_free_symbol (sym);
2188 gfc_free (sym_tree);
2192 /* Free a namespace structure and everything below it. Interface
2193 lists associated with intrinsic operators are not freed. These are
2194 taken care of when a specific name is freed. */
2197 gfc_free_namespace (gfc_namespace * ns)
2199 gfc_charlen *cl, *cl2;
2200 gfc_namespace *p, *q;
2209 gcc_assert (ns->refs == 0);
2211 gfc_free_statements (ns->code);
2213 free_sym_tree (ns->sym_root);
2214 free_uop_tree (ns->uop_root);
2215 free_common_tree (ns->common_root);
2217 for (cl = ns->cl_list; cl; cl = cl2)
2220 gfc_free_expr (cl->length);
2224 free_st_labels (ns->st_labels);
2226 gfc_free_equiv (ns->equiv);
2228 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2229 gfc_free_interface (ns->operator[i]);
2231 gfc_free_data (ns->data);
2235 /* Recursively free any contained namespaces. */
2241 gfc_free_namespace (q);
2247 gfc_symbol_init_2 (void)
2250 gfc_current_ns = gfc_get_namespace (NULL, 0);
2255 gfc_symbol_done_2 (void)
2258 gfc_free_namespace (gfc_current_ns);
2259 gfc_current_ns = NULL;
2263 /* Clear mark bits from symbol nodes associated with a symtree node. */
2266 clear_sym_mark (gfc_symtree * st)
2269 st->n.sym->mark = 0;
2273 /* Recursively traverse the symtree nodes. */
2276 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2282 gfc_traverse_symtree (st->left, func);
2283 gfc_traverse_symtree (st->right, func);
2288 /* Recursive namespace traversal function. */
2291 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2297 if (st->n.sym->mark == 0)
2298 (*func) (st->n.sym);
2299 st->n.sym->mark = 1;
2301 traverse_ns (st->left, func);
2302 traverse_ns (st->right, func);
2306 /* Call a given function for all symbols in the namespace. We take
2307 care that each gfc_symbol node is called exactly once. */
2310 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2313 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2315 traverse_ns (ns->sym_root, func);
2319 /* Given a symbol, mark it as SAVEd if it is allowed. */
2322 save_symbol (gfc_symbol * sym)
2325 if (sym->attr.use_assoc)
2328 if (sym->attr.in_common
2330 || sym->attr.flavor != FL_VARIABLE)
2333 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2337 /* Mark those symbols which can be SAVEd as such. */
2340 gfc_save_all (gfc_namespace * ns)
2343 gfc_traverse_ns (ns, save_symbol);
2348 /* Make sure that no changes to symbols are pending. */
2351 gfc_symbol_state(void) {
2353 if (changed_syms != NULL)
2354 gfc_internal_error("Symbol changes still pending!");
2359 /************** Global symbol handling ************/
2362 /* Search a tree for the global symbol. */
2365 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
2371 if (strcmp (symbol->name, name) == 0)
2374 s = gfc_find_gsymbol (symbol->left, name);
2378 s = gfc_find_gsymbol (symbol->right, name);
2386 /* Compare two global symbols. Used for managing the BB tree. */
2389 gsym_compare (void * _s1, void * _s2)
2391 gfc_gsymbol *s1, *s2;
2393 s1 = (gfc_gsymbol *)_s1;
2394 s2 = (gfc_gsymbol *)_s2;
2395 return strcmp(s1->name, s2->name);
2399 /* Get a global symbol, creating it if it doesn't exist. */
2402 gfc_get_gsymbol (const char *name)
2406 s = gfc_find_gsymbol (gfc_gsym_root, name);
2410 s = gfc_getmem (sizeof (gfc_gsymbol));
2411 s->type = GSYM_UNKNOWN;
2412 strcpy (s->name, name);
2414 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);