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 it's default
186 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
190 letter = sym->name[0];
191 if (letter < 'a' || letter > 'z')
192 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
197 return &ns->default_type[letter - 'a'];
201 /* Given a pointer to a symbol, set its type according to the first
202 letter of its name. Fails if the letter in question has no default
206 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
210 if (sym->ts.type != BT_UNKNOWN)
211 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
213 ts = gfc_get_default_type (sym, ns);
215 if (ts->type == BT_UNKNOWN)
218 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
225 sym->attr.implicit_type = 1;
231 /******************** Symbol attribute stuff *********************/
233 /* This is a generic conflict-checker. We do this to avoid having a
234 single conflict in two places. */
236 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
237 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
240 check_conflict (symbol_attribute * attr, locus * where)
242 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
243 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
244 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
245 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
246 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
247 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
248 *function = "FUNCTION", *subroutine = "SUBROUTINE",
249 *dimension = "DIMENSION";
254 where = &gfc_current_locus;
256 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
263 /* Check for attributes not allowed in a BLOCK DATA. */
264 if (gfc_current_state () == COMP_BLOCK_DATA)
268 if (attr->allocatable)
274 if (attr->access == ACCESS_PRIVATE)
276 if (attr->access == ACCESS_PUBLIC)
278 if (attr->intent != INTENT_UNKNOWN)
284 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
291 conf (pointer, target);
292 conf (pointer, external);
293 conf (pointer, intrinsic);
294 conf (target, external);
295 conf (target, intrinsic);
296 conf (external, dimension); /* See Fortran 95's R504. */
298 conf (external, intrinsic);
299 conf (allocatable, pointer);
300 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
301 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
302 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
303 conf (elemental, recursive);
305 conf (in_common, dummy);
306 conf (in_common, allocatable);
307 conf (in_common, result);
308 conf (dummy, result);
310 conf (in_namelist, pointer);
311 conf (in_namelist, allocatable);
313 conf (entry, result);
315 conf (function, subroutine);
317 a1 = gfc_code2string (flavors, attr->flavor);
319 if (attr->in_namelist
320 && attr->flavor != FL_VARIABLE
321 && attr->flavor != FL_UNKNOWN)
328 switch (attr->flavor)
355 if (attr->subroutine)
368 case PROC_ST_FUNCTION:
401 if (attr->intent != INTENT_UNKNOWN)
429 gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where);
437 /* Mark a symbol as referenced. */
440 gfc_set_sym_referenced (gfc_symbol * sym)
442 if (sym->attr.referenced)
445 sym->attr.referenced = 1;
447 /* Remember which order dummy variables are accessed in. */
449 sym->dummy_order = next_dummy_order++;
453 /* Common subroutine called by attribute changing subroutines in order
454 to prevent them from changing a symbol that has been
455 use-associated. Returns zero if it is OK to change the symbol,
459 check_used (symbol_attribute * attr, locus * where)
462 if (attr->use_assoc == 0)
466 where = &gfc_current_locus;
468 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
475 /* Used to prevent changing the attributes of a symbol after it has been
476 used. This check is only done from dummy variable as only these can be
477 used in specification expressions. Applying this to all symbols causes
478 error when we reach the body of a contained function. */
481 check_done (symbol_attribute * attr, locus * where)
484 if (!(attr->dummy && attr->referenced))
488 where = &gfc_current_locus;
490 gfc_error ("Cannot change attributes of symbol at %L"
491 " after it has been used", where);
497 /* Generate an error because of a duplicate attribute. */
500 duplicate_attr (const char *attr, locus * where)
504 where = &gfc_current_locus;
506 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
511 gfc_add_allocatable (symbol_attribute * attr, locus * where)
514 if (check_used (attr, where) || check_done (attr, where))
517 if (attr->allocatable)
519 duplicate_attr ("ALLOCATABLE", where);
523 attr->allocatable = 1;
524 return check_conflict (attr, where);
529 gfc_add_dimension (symbol_attribute * attr, locus * where)
532 if (check_used (attr, where) || check_done (attr, where))
537 duplicate_attr ("DIMENSION", where);
542 return check_conflict (attr, where);
547 gfc_add_external (symbol_attribute * attr, locus * where)
550 if (check_used (attr, where) || check_done (attr, where))
555 duplicate_attr ("EXTERNAL", where);
561 return check_conflict (attr, where);
566 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
569 if (check_used (attr, where) || check_done (attr, where))
574 duplicate_attr ("INTRINSIC", where);
580 return check_conflict (attr, where);
585 gfc_add_optional (symbol_attribute * attr, locus * where)
588 if (check_used (attr, where) || check_done (attr, where))
593 duplicate_attr ("OPTIONAL", where);
598 return check_conflict (attr, where);
603 gfc_add_pointer (symbol_attribute * attr, locus * where)
606 if (check_used (attr, where) || check_done (attr, where))
610 return check_conflict (attr, where);
615 gfc_add_result (symbol_attribute * attr, locus * where)
618 if (check_used (attr, where) || check_done (attr, where))
622 return check_conflict (attr, where);
627 gfc_add_save (symbol_attribute * attr, locus * where)
630 if (check_used (attr, where))
636 ("SAVE attribute at %L cannot be specified in a PURE procedure",
643 duplicate_attr ("SAVE", where);
648 return check_conflict (attr, where);
653 gfc_add_target (symbol_attribute * attr, locus * where)
656 if (check_used (attr, where) || check_done (attr, where))
661 duplicate_attr ("TARGET", where);
666 return check_conflict (attr, where);
671 gfc_add_dummy (symbol_attribute * attr, locus * where)
674 if (check_used (attr, where))
677 /* Duplicate dummy arguments are allow due to ENTRY statements. */
679 return check_conflict (attr, where);
684 gfc_add_in_common (symbol_attribute * attr, locus * where)
687 if (check_used (attr, where) || check_done (attr, where))
690 /* Duplicate attribute already checked for. */
692 if (check_conflict (attr, where) == FAILURE)
695 if (attr->flavor == FL_VARIABLE)
698 return gfc_add_flavor (attr, FL_VARIABLE, where);
703 gfc_add_data (symbol_attribute *attr, locus *where)
706 if (check_used (attr, where))
710 return check_conflict (attr, where);
715 gfc_add_in_namelist (symbol_attribute * attr, locus * where)
718 attr->in_namelist = 1;
719 return check_conflict (attr, where);
724 gfc_add_sequence (symbol_attribute * attr, locus * where)
727 if (check_used (attr, where))
731 return check_conflict (attr, where);
736 gfc_add_elemental (symbol_attribute * attr, locus * where)
739 if (check_used (attr, where) || check_done (attr, where))
743 return check_conflict (attr, where);
748 gfc_add_pure (symbol_attribute * attr, locus * where)
751 if (check_used (attr, where) || check_done (attr, where))
755 return check_conflict (attr, where);
760 gfc_add_recursive (symbol_attribute * attr, locus * where)
763 if (check_used (attr, where) || check_done (attr, where))
767 return check_conflict (attr, where);
772 gfc_add_entry (symbol_attribute * attr, locus * where)
775 if (check_used (attr, where))
780 duplicate_attr ("ENTRY", where);
785 return check_conflict (attr, where);
790 gfc_add_function (symbol_attribute * attr, locus * where)
793 if (attr->flavor != FL_PROCEDURE
794 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
798 return check_conflict (attr, where);
803 gfc_add_subroutine (symbol_attribute * attr, locus * where)
806 if (attr->flavor != FL_PROCEDURE
807 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
810 attr->subroutine = 1;
811 return check_conflict (attr, where);
816 gfc_add_generic (symbol_attribute * attr, locus * where)
819 if (attr->flavor != FL_PROCEDURE
820 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
824 return check_conflict (attr, where);
828 /* Flavors are special because some flavors are not what fortran
829 considers attributes and can be reaffirmed multiple times. */
832 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
835 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
836 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
837 || f == FL_NAMELIST) && check_used (attr, where))
840 if (attr->flavor == f && f == FL_VARIABLE)
843 if (attr->flavor != FL_UNKNOWN)
846 where = &gfc_current_locus;
848 gfc_error ("%s attribute conflicts with %s attribute at %L",
849 gfc_code2string (flavors, attr->flavor),
850 gfc_code2string (flavors, f), where);
857 return check_conflict (attr, where);
862 gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
865 if (check_used (attr, where) || check_done (attr, where))
868 if (attr->flavor != FL_PROCEDURE
869 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
873 where = &gfc_current_locus;
875 if (attr->proc != PROC_UNKNOWN)
877 gfc_error ("%s procedure at %L is already %s %s procedure",
878 gfc_code2string (procedures, t), where,
879 gfc_article (gfc_code2string (procedures, attr->proc)),
880 gfc_code2string (procedures, attr->proc));
887 /* Statement functions are always scalar and functions. */
888 if (t == PROC_ST_FUNCTION
889 && ((!attr->function && gfc_add_function (attr, where) == FAILURE)
893 return check_conflict (attr, where);
898 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
901 if (check_used (attr, where))
904 if (attr->intent == INTENT_UNKNOWN)
906 attr->intent = intent;
907 return check_conflict (attr, where);
911 where = &gfc_current_locus;
913 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
914 gfc_intent_string (attr->intent),
915 gfc_intent_string (intent), where);
921 /* No checks for use-association in public and private statements. */
924 gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where)
927 if (attr->access == ACCESS_UNKNOWN)
929 attr->access = access;
930 return check_conflict (attr, where);
934 where = &gfc_current_locus;
935 gfc_error ("ACCESS specification at %L was already specified", where);
942 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
943 gfc_formal_arglist * formal, locus * where)
946 if (check_used (&sym->attr, where))
950 where = &gfc_current_locus;
952 if (sym->attr.if_source != IFSRC_UNKNOWN
953 && sym->attr.if_source != IFSRC_DECL)
955 gfc_error ("Symbol '%s' at %L already has an explicit interface",
960 sym->formal = formal;
961 sym->attr.if_source = source;
967 /* Add a type to a symbol. */
970 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
974 /* TODO: This is legal if it is reaffirming an implicit type.
975 if (check_done (&sym->attr, where))
979 where = &gfc_current_locus;
981 if (sym->ts.type != BT_UNKNOWN)
983 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
984 where, gfc_basic_typename (sym->ts.type));
988 flavor = sym->attr.flavor;
990 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
991 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
992 && sym->attr.subroutine)
993 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
995 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1004 /* Clears all attributes. */
1007 gfc_clear_attr (symbol_attribute * attr)
1009 memset (attr, 0, sizeof(symbol_attribute));
1013 /* Check for missing attributes in the new symbol. Currently does
1014 nothing, but it's not clear that it is unnecessary yet. */
1017 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1018 locus * where ATTRIBUTE_UNUSED)
1025 /* Copy an attribute to a symbol attribute, bit by bit. Some
1026 attributes have a lot of side-effects but cannot be present given
1027 where we are called from, so we ignore some bits. */
1030 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1033 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1036 if (src->dimension && gfc_add_dimension (dest, where) == FAILURE)
1038 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1040 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1042 if (src->save && gfc_add_save (dest, where) == FAILURE)
1044 if (src->target && gfc_add_target (dest, where) == FAILURE)
1046 if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
1048 if (src->result && gfc_add_result (dest, where) == FAILURE)
1053 if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE)
1056 if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
1059 if (src->generic && gfc_add_generic (dest, where) == FAILURE)
1061 if (src->function && gfc_add_function (dest, where) == FAILURE)
1063 if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE)
1066 if (src->sequence && gfc_add_sequence (dest, where) == FAILURE)
1068 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1070 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1072 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1075 if (src->flavor != FL_UNKNOWN
1076 && gfc_add_flavor (dest, src->flavor, where) == FAILURE)
1079 if (src->intent != INTENT_UNKNOWN
1080 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1083 if (src->access != ACCESS_UNKNOWN
1084 && gfc_add_access (dest, src->access, where) == FAILURE)
1087 if (gfc_missing_attr (dest, where) == FAILURE)
1090 /* The subroutines that set these bits also cause flavors to be set,
1091 and that has already happened in the original, so don't let to
1096 dest->intrinsic = 1;
1105 /************** Component name management ************/
1107 /* Component names of a derived type form their own little namespaces
1108 that are separate from all other spaces. The space is composed of
1109 a singly linked list of gfc_component structures whose head is
1110 located in the parent symbol. */
1113 /* Add a component name to a symbol. The call fails if the name is
1114 already present. On success, the component pointer is modified to
1115 point to the additional component structure. */
1118 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1120 gfc_component *p, *tail;
1124 for (p = sym->components; p; p = p->next)
1126 if (strcmp (p->name, name) == 0)
1128 gfc_error ("Component '%s' at %C already declared at %L",
1136 /* Allocate new component */
1137 p = gfc_get_component ();
1140 sym->components = p;
1144 strcpy (p->name, name);
1145 p->loc = gfc_current_locus;
1152 /* Recursive function to switch derived types of all symbol in a
1156 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1164 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1165 sym->ts.derived = to;
1167 switch_types (st->left, from, to);
1168 switch_types (st->right, from, to);
1172 /* This subroutine is called when a derived type is used in order to
1173 make the final determination about which version to use. The
1174 standard requires that a type be defined before it is 'used', but
1175 such types can appear in IMPLICIT statements before the actual
1176 definition. 'Using' in this context means declaring a variable to
1177 be that type or using the type constructor.
1179 If a type is used and the components haven't been defined, then we
1180 have to have a derived type in a parent unit. We find the node in
1181 the other namespace and point the symtree node in this namespace to
1182 that node. Further reference to this name point to the correct
1183 node. If we can't find the node in a parent namespace, then have
1186 This subroutine takes a pointer to a symbol node and returns a
1187 pointer to the translated node or NULL for an error. Usually there
1188 is no translation and we return the node we were passed. */
1190 static gfc_symtree *
1191 gfc_use_ha_derived (gfc_symbol * sym)
1198 if (sym->ns->parent == NULL)
1201 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1203 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1207 if (s == NULL || s->attr.flavor != FL_DERIVED)
1210 /* Get rid of symbol sym, translating all references to s. */
1211 for (i = 0; i < GFC_LETTERS; i++)
1213 t = &sym->ns->default_type[i];
1214 if (t->derived == sym)
1218 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1223 /* Unlink from list of modified symbols. */
1224 if (changed_syms == sym)
1225 changed_syms = sym->tlink;
1227 for (p = changed_syms; p; p = p->tlink)
1228 if (p->tlink == sym)
1230 p->tlink = sym->tlink;
1234 switch_types (sym->ns->sym_root, sym, s);
1236 /* TODO: Also have to replace sym -> s in other lists like
1237 namelists, common lists and interface lists. */
1238 gfc_free_symbol (sym);
1243 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1250 gfc_use_derived (gfc_symbol * sym)
1254 if (sym->components != NULL)
1255 return sym; /* Already defined */
1257 st = gfc_use_ha_derived (sym);
1265 /* Given a derived type node and a component name, try to locate the
1266 component structure. Returns the NULL pointer if the component is
1267 not found or the components are private. */
1270 gfc_find_component (gfc_symbol * sym, const char *name)
1277 sym = gfc_use_derived (sym);
1282 for (p = sym->components; p; p = p->next)
1283 if (strcmp (p->name, name) == 0)
1287 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1291 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1293 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1303 /* Given a symbol, free all of the component structures and everything
1307 free_components (gfc_component * p)
1315 gfc_free_array_spec (p->as);
1316 gfc_free_expr (p->initializer);
1323 /* Set component attributes from a standard symbol attribute
1327 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1330 c->dimension = attr->dimension;
1331 c->pointer = attr->pointer;
1335 /* Get a standard symbol attribute structure given the component
1339 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1342 gfc_clear_attr (attr);
1343 attr->dimension = c->dimension;
1344 attr->pointer = c->pointer;
1348 /******************** Statement label management ********************/
1350 /* Free a single gfc_st_label structure, making sure the list is not
1351 messed up. This function is called only when some parse error
1355 gfc_free_st_label (gfc_st_label * l)
1362 (l->prev->next = l->next);
1365 (l->next->prev = l->prev);
1367 if (l->format != NULL)
1368 gfc_free_expr (l->format);
1372 /* Free a whole list of gfc_st_label structures. */
1375 free_st_labels (gfc_st_label * l1)
1382 if (l1->format != NULL)
1383 gfc_free_expr (l1->format);
1389 /* Given a label number, search for and return a pointer to the label
1390 structure, creating it if it does not exist. */
1393 gfc_get_st_label (int labelno)
1397 /* First see if the label is already in this namespace. */
1398 for (lp = gfc_current_ns->st_labels; lp; lp = lp->next)
1399 if (lp->value == labelno)
1404 lp = gfc_getmem (sizeof (gfc_st_label));
1406 lp->value = labelno;
1407 lp->defined = ST_LABEL_UNKNOWN;
1408 lp->referenced = ST_LABEL_UNKNOWN;
1411 lp->next = gfc_current_ns->st_labels;
1412 if (gfc_current_ns->st_labels)
1413 gfc_current_ns->st_labels->prev = lp;
1414 gfc_current_ns->st_labels = lp;
1420 /* Called when a statement with a statement label is about to be
1421 accepted. We add the label to the list of the current namespace,
1422 making sure it hasn't been defined previously and referenced
1426 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1430 labelno = lp->value;
1432 if (lp->defined != ST_LABEL_UNKNOWN)
1433 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1434 &lp->where, label_locus);
1437 lp->where = *label_locus;
1441 case ST_LABEL_FORMAT:
1442 if (lp->referenced == ST_LABEL_TARGET)
1443 gfc_error ("Label %d at %C already referenced as branch target",
1446 lp->defined = ST_LABEL_FORMAT;
1450 case ST_LABEL_TARGET:
1451 if (lp->referenced == ST_LABEL_FORMAT)
1452 gfc_error ("Label %d at %C already referenced as a format label",
1455 lp->defined = ST_LABEL_TARGET;
1460 lp->defined = ST_LABEL_BAD_TARGET;
1461 lp->referenced = ST_LABEL_BAD_TARGET;
1467 /* Reference a label. Given a label and its type, see if that
1468 reference is consistent with what is known about that label,
1469 updating the unknown state. Returns FAILURE if something goes
1473 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1475 gfc_sl_type label_type;
1482 labelno = lp->value;
1484 if (lp->defined != ST_LABEL_UNKNOWN)
1485 label_type = lp->defined;
1488 label_type = lp->referenced;
1489 lp->where = gfc_current_locus;
1492 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1494 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1499 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1500 && type == ST_LABEL_FORMAT)
1502 gfc_error ("Label %d at %C previously used as branch target", labelno);
1507 lp->referenced = type;
1515 /************** Symbol table management subroutines ****************/
1517 /* Basic details: Fortran 95 requires a potentially unlimited number
1518 of distinct namespaces when compiling a program unit. This case
1519 occurs during a compilation of internal subprograms because all of
1520 the internal subprograms must be read before we can start
1521 generating code for the host.
1523 Given the tricky nature of the fortran grammar, we must be able to
1524 undo changes made to a symbol table if the current interpretation
1525 of a statement is found to be incorrect. Whenever a symbol is
1526 looked up, we make a copy of it and link to it. All of these
1527 symbols are kept in a singly linked list so that we can commit or
1528 undo the changes at a later time.
1530 A symtree may point to a symbol node outside of its namespace. In
1531 this case, that symbol has been used as a host associated variable
1532 at some previous time. */
1534 /* Allocate a new namespace structure. */
1537 gfc_get_namespace (gfc_namespace * parent)
1541 gfc_intrinsic_op in;
1544 ns = gfc_getmem (sizeof (gfc_namespace));
1545 ns->sym_root = NULL;
1546 ns->uop_root = NULL;
1547 ns->default_access = ACCESS_UNKNOWN;
1548 ns->parent = parent;
1550 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1551 ns->operator_access[in] = ACCESS_UNKNOWN;
1553 /* Initialize default implicit types. */
1554 for (i = 'a'; i <= 'z'; i++)
1556 ns->set_flag[i - 'a'] = 0;
1557 ts = &ns->default_type[i - 'a'];
1559 if (ns->parent != NULL)
1561 /* Copy parent settings */
1562 *ts = ns->parent->default_type[i - 'a'];
1566 if (gfc_option.flag_implicit_none != 0)
1572 if ('i' <= i && i <= 'n')
1574 ts->type = BT_INTEGER;
1575 ts->kind = gfc_default_integer_kind;
1580 ts->kind = gfc_default_real_kind;
1590 /* Comparison function for symtree nodes. */
1593 compare_symtree (void * _st1, void * _st2)
1595 gfc_symtree *st1, *st2;
1597 st1 = (gfc_symtree *) _st1;
1598 st2 = (gfc_symtree *) _st2;
1600 return strcmp (st1->name, st2->name);
1604 /* Allocate a new symtree node and associate it with the new symbol. */
1607 gfc_new_symtree (gfc_symtree ** root, const char *name)
1611 st = gfc_getmem (sizeof (gfc_symtree));
1612 strcpy (st->name, name);
1614 gfc_insert_bbt (root, st, compare_symtree);
1619 /* Delete a symbol from the tree. Does not free the symbol itself! */
1622 delete_symtree (gfc_symtree ** root, const char *name)
1624 gfc_symtree st, *st0;
1626 st0 = gfc_find_symtree (*root, name);
1628 strcpy (st.name, name);
1629 gfc_delete_bbt (root, &st, compare_symtree);
1635 /* Given a root symtree node and a name, try to find the symbol within
1636 the namespace. Returns NULL if the symbol is not found. */
1639 gfc_find_symtree (gfc_symtree * st, const char *name)
1645 c = strcmp (name, st->name);
1649 st = (c < 0) ? st->left : st->right;
1656 /* Given a name find a user operator node, creating it if it doesn't
1657 exist. These are much simpler than symbols because they can't be
1658 ambiguous with one another. */
1661 gfc_get_uop (const char *name)
1666 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1670 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1672 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1673 strcpy (uop->name, name);
1674 uop->access = ACCESS_UNKNOWN;
1675 uop->ns = gfc_current_ns;
1681 /* Given a name find the user operator node. Returns NULL if it does
1685 gfc_find_uop (const char *name, gfc_namespace * ns)
1690 ns = gfc_current_ns;
1692 st = gfc_find_symtree (ns->uop_root, name);
1693 return (st == NULL) ? NULL : st->n.uop;
1697 /* Remove a gfc_symbol structure and everything it points to. */
1700 gfc_free_symbol (gfc_symbol * sym)
1706 gfc_free_array_spec (sym->as);
1708 free_components (sym->components);
1710 gfc_free_expr (sym->value);
1712 gfc_free_namelist (sym->namelist);
1714 gfc_free_namespace (sym->formal_ns);
1716 gfc_free_interface (sym->generic);
1718 gfc_free_formal_arglist (sym->formal);
1724 /* Allocate and initialize a new symbol node. */
1727 gfc_new_symbol (const char *name, gfc_namespace * ns)
1731 p = gfc_getmem (sizeof (gfc_symbol));
1733 gfc_clear_ts (&p->ts);
1734 gfc_clear_attr (&p->attr);
1737 p->declared_at = gfc_current_locus;
1739 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1740 gfc_internal_error ("new_symbol(): Symbol name too long");
1742 strcpy (p->name, name);
1747 /* Generate an error if a symbol is ambiguous. */
1750 ambiguous_symbol (const char *name, gfc_symtree * st)
1753 if (st->n.sym->module[0])
1754 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1755 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1757 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1758 "from current program unit", name, st->n.sym->name);
1762 /* Search for a symtree starting in the current namespace, resorting to
1763 any parent namespaces if requested by a nonzero parent_flag.
1764 Returns nonzero if the name is ambiguous. */
1767 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1768 gfc_symtree ** result)
1773 ns = gfc_current_ns;
1777 st = gfc_find_symtree (ns->sym_root, name);
1783 ambiguous_symbol (name, st);
1802 /* Same, but returns the symbol instead. */
1805 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1806 gfc_symbol ** result)
1811 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1816 *result = st->n.sym;
1822 /* Save symbol with the information necessary to back it out. */
1825 save_symbol_data (gfc_symbol * sym)
1828 if (sym->new || sym->old_symbol != NULL)
1831 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1832 *(sym->old_symbol) = *sym;
1834 sym->tlink = changed_syms;
1839 /* Given a name, find a symbol, or create it if it does not exist yet
1840 in the current namespace. If the symbol is found we make sure that
1843 The integer return code indicates
1845 1 The symbol name was ambiguous
1846 2 The name meant to be established was already host associated.
1848 So if the return value is nonzero, then an error was issued. */
1851 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1856 /* This doesn't usually happen during resolution. */
1858 ns = gfc_current_ns;
1860 /* Try to find the symbol in ns. */
1861 st = gfc_find_symtree (ns->sym_root, name);
1865 /* If not there, create a new symbol. */
1866 p = gfc_new_symbol (name, ns);
1868 /* Add to the list of tentative symbols. */
1869 p->old_symbol = NULL;
1870 p->tlink = changed_syms;
1875 st = gfc_new_symtree (&ns->sym_root, name);
1882 /* Make sure the existing symbol is OK. */
1885 ambiguous_symbol (name, st);
1891 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1893 /* Symbol is from another namespace. */
1894 gfc_error ("Symbol '%s' at %C has already been host associated",
1901 /* Copy in case this symbol is changed. */
1902 save_symbol_data (p);
1911 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1917 i = gfc_get_sym_tree (name, ns, &st);
1922 *result = st->n.sym;
1929 /* Subroutine that searches for a symbol, creating it if it doesn't
1930 exist, but tries to host-associate the symbol if possible. */
1933 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1938 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1941 save_symbol_data (st->n.sym);
1947 if (gfc_current_ns->parent != NULL)
1949 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1960 return gfc_get_sym_tree (name, gfc_current_ns, result);
1965 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
1970 i = gfc_get_ha_sym_tree (name, &st);
1973 *result = st->n.sym;
1980 /* Return true if both symbols could refer to the same data object. Does
1981 not take account of aliasing due to equivalence statements. */
1984 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
1986 /* Aliasing isn't possible if the symbols have different base types. */
1987 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
1990 /* Pointers can point to other pointers, target objects and allocatable
1991 objects. Two allocatable objects cannot share the same storage. */
1992 if (lsym->attr.pointer
1993 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
1995 if (lsym->attr.target && rsym->attr.pointer)
1997 if (lsym->attr.allocatable && rsym->attr.pointer)
2004 /* Undoes all the changes made to symbols in the current statement.
2005 This subroutine is made simpler due to the fact that attributes are
2006 never removed once added. */
2009 gfc_undo_symbols (void)
2011 gfc_symbol *p, *q, *old;
2013 for (p = changed_syms; p; p = q)
2019 /* Symbol was new. */
2020 delete_symtree (&p->ns->sym_root, p->name);
2024 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2026 gfc_free_symbol (p);
2030 /* Restore previous state of symbol. Just copy simple stuff. */
2032 old = p->old_symbol;
2034 p->ts.type = old->ts.type;
2035 p->ts.kind = old->ts.kind;
2037 p->attr = old->attr;
2039 if (p->value != old->value)
2041 gfc_free_expr (old->value);
2045 if (p->as != old->as)
2048 gfc_free_array_spec (p->as);
2052 p->generic = old->generic;
2053 p->component_access = old->component_access;
2055 if (p->namelist != NULL && old->namelist == NULL)
2057 gfc_free_namelist (p->namelist);
2063 if (p->namelist_tail != old->namelist_tail)
2065 gfc_free_namelist (old->namelist_tail);
2066 old->namelist_tail->next = NULL;
2070 p->namelist_tail = old->namelist_tail;
2072 if (p->formal != old->formal)
2074 gfc_free_formal_arglist (p->formal);
2075 p->formal = old->formal;
2078 gfc_free (p->old_symbol);
2079 p->old_symbol = NULL;
2083 changed_syms = NULL;
2087 /* Makes the changes made in the current statement permanent-- gets
2088 rid of undo information. */
2091 gfc_commit_symbols (void)
2095 for (p = changed_syms; p; p = q)
2102 if (p->old_symbol != NULL)
2104 gfc_free (p->old_symbol);
2105 p->old_symbol = NULL;
2109 changed_syms = NULL;
2113 /* Recursive function that deletes an entire tree and all the common
2114 head structures it points to. */
2117 free_common_tree (gfc_symtree * common_tree)
2119 if (common_tree == NULL)
2122 free_common_tree (common_tree->left);
2123 free_common_tree (common_tree->right);
2125 gfc_free (common_tree);
2129 /* Recursive function that deletes an entire tree and all the user
2130 operator nodes that it contains. */
2133 free_uop_tree (gfc_symtree * uop_tree)
2136 if (uop_tree == NULL)
2139 free_uop_tree (uop_tree->left);
2140 free_uop_tree (uop_tree->right);
2142 gfc_free_interface (uop_tree->n.uop->operator);
2144 gfc_free (uop_tree->n.uop);
2145 gfc_free (uop_tree);
2149 /* Recursive function that deletes an entire tree and all the symbols
2150 that it contains. */
2153 free_sym_tree (gfc_symtree * sym_tree)
2158 if (sym_tree == NULL)
2161 free_sym_tree (sym_tree->left);
2162 free_sym_tree (sym_tree->right);
2164 sym = sym_tree->n.sym;
2168 gfc_internal_error ("free_sym_tree(): Negative refs");
2170 if (sym->formal_ns != NULL && sym->refs == 1)
2172 /* As formal_ns contains a reference to sym, delete formal_ns just
2173 before the deletion of sym. */
2174 ns = sym->formal_ns;
2175 sym->formal_ns = NULL;
2176 gfc_free_namespace (ns);
2178 else if (sym->refs == 0)
2180 /* Go ahead and delete the symbol. */
2181 gfc_free_symbol (sym);
2184 gfc_free (sym_tree);
2188 /* Free a namespace structure and everything below it. Interface
2189 lists associated with intrinsic operators are not freed. These are
2190 taken care of when a specific name is freed. */
2193 gfc_free_namespace (gfc_namespace * ns)
2195 gfc_charlen *cl, *cl2;
2196 gfc_namespace *p, *q;
2205 gcc_assert (ns->refs == 0);
2207 gfc_free_statements (ns->code);
2209 free_sym_tree (ns->sym_root);
2210 free_uop_tree (ns->uop_root);
2211 free_common_tree (ns->common_root);
2213 for (cl = ns->cl_list; cl; cl = cl2)
2216 gfc_free_expr (cl->length);
2220 free_st_labels (ns->st_labels);
2222 gfc_free_equiv (ns->equiv);
2224 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2225 gfc_free_interface (ns->operator[i]);
2227 gfc_free_data (ns->data);
2231 /* Recursively free any contained namespaces. */
2237 gfc_free_namespace (q);
2243 gfc_symbol_init_2 (void)
2246 gfc_current_ns = gfc_get_namespace (NULL);
2251 gfc_symbol_done_2 (void)
2254 gfc_free_namespace (gfc_current_ns);
2255 gfc_current_ns = NULL;
2259 /* Clear mark bits from symbol nodes associated with a symtree node. */
2262 clear_sym_mark (gfc_symtree * st)
2265 st->n.sym->mark = 0;
2269 /* Recursively traverse the symtree nodes. */
2272 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2278 gfc_traverse_symtree (st->left, func);
2279 gfc_traverse_symtree (st->right, func);
2284 /* Recursive namespace traversal function. */
2287 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2293 if (st->n.sym->mark == 0)
2294 (*func) (st->n.sym);
2295 st->n.sym->mark = 1;
2297 traverse_ns (st->left, func);
2298 traverse_ns (st->right, func);
2302 /* Call a given function for all symbols in the namespace. We take
2303 care that each gfc_symbol node is called exactly once. */
2306 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2309 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2311 traverse_ns (ns->sym_root, func);
2315 /* Given a symbol, mark it as SAVEd if it is allowed. */
2318 save_symbol (gfc_symbol * sym)
2321 if (sym->attr.use_assoc)
2324 if (sym->attr.in_common
2326 || sym->attr.flavor != FL_VARIABLE)
2329 gfc_add_save (&sym->attr, &sym->declared_at);
2333 /* Mark those symbols which can be SAVEd as such. */
2336 gfc_save_all (gfc_namespace * ns)
2339 gfc_traverse_ns (ns, save_symbol);
2344 /* Make sure that no changes to symbols are pending. */
2347 gfc_symbol_state(void) {
2349 if (changed_syms != NULL)
2350 gfc_internal_error("Symbol changes still pending!");
2355 /************** Global symbol handling ************/
2358 /* Search a tree for the global symbol. */
2361 gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
2367 if (strcmp (symbol->name, name) == 0)
2370 s = gfc_find_gsymbol (symbol->left, name);
2374 s = gfc_find_gsymbol (symbol->right, name);
2382 /* Compare two global symbols. Used for managing the BB tree. */
2385 gsym_compare (void * _s1, void * _s2)
2387 gfc_gsymbol *s1, *s2;
2389 s1 = (gfc_gsymbol *)_s1;
2390 s2 = (gfc_gsymbol *)_s2;
2391 return strcmp(s1->name, s2->name);
2395 /* Get a global symbol, creating it if it doesn't exist. */
2398 gfc_get_gsymbol (char *name)
2402 s = gfc_find_gsymbol (gfc_gsym_root, name);
2406 s = gfc_getmem (sizeof (gfc_gsymbol));
2407 s->type = GSYM_UNKNOWN;
2408 strcpy (s->name, name);
2410 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);