1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
32 /* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
36 const mstring flavors[] =
38 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
46 const mstring procedures[] =
48 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
49 minit ("MODULE-PROC", PROC_MODULE),
50 minit ("INTERNAL-PROC", PROC_INTERNAL),
51 minit ("DUMMY-PROC", PROC_DUMMY),
52 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
53 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
54 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
58 const mstring intents[] =
60 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
61 minit ("IN", INTENT_IN),
62 minit ("OUT", INTENT_OUT),
63 minit ("INOUT", INTENT_INOUT),
67 const mstring access_types[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70 minit ("PUBLIC", ACCESS_PUBLIC),
71 minit ("PRIVATE", ACCESS_PRIVATE),
75 const mstring ifsrc_types[] =
77 minit ("UNKNOWN", IFSRC_UNKNOWN),
78 minit ("DECL", IFSRC_DECL),
79 minit ("BODY", IFSRC_IFBODY),
80 minit ("USAGE", IFSRC_USAGE)
84 /* This is to make sure the backend generates setup code in the correct
87 static int next_dummy_order = 1;
90 gfc_namespace *gfc_current_ns;
92 gfc_gsymbol *gfc_gsym_root = NULL;
94 static gfc_symbol *changed_syms = NULL;
97 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
99 /* The following static variable indicates whether a particular element has
100 been explicitly set or not. */
102 static int new_flag[GFC_LETTERS];
105 /* Handle a correctly parsed IMPLICIT NONE. */
108 gfc_set_implicit_none (void)
112 for (i = 0; i < GFC_LETTERS; i++)
114 gfc_clear_ts (&gfc_current_ns->default_type[i]);
115 gfc_current_ns->set_flag[i] = 1;
120 /* Reset the implicit range flags. */
123 gfc_clear_new_implicit (void)
127 for (i = 0; i < GFC_LETTERS; i++)
132 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
135 gfc_add_new_implicit_range (int c1, int c2)
142 for (i = c1; i <= c2; i++)
146 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
158 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
159 the new implicit types back into the existing types will work. */
162 gfc_merge_new_implicit (gfc_typespec * ts)
166 for (i = 0; i < GFC_LETTERS; i++)
171 if (gfc_current_ns->set_flag[i])
173 gfc_error ("Letter %c already has an IMPLICIT type at %C",
177 gfc_current_ns->default_type[i] = *ts;
178 gfc_current_ns->set_flag[i] = 1;
185 /* Given a symbol, return a pointer to the typespec for it's default
189 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
193 letter = sym->name[0];
194 if (letter < 'a' || letter > 'z')
195 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
200 return &ns->default_type[letter - 'a'];
204 /* Given a pointer to a symbol, set its type according to the first
205 letter of its name. Fails if the letter in question has no default
209 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
213 if (sym->ts.type != BT_UNKNOWN)
214 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
216 ts = gfc_get_default_type (sym, ns);
218 if (ts->type == BT_UNKNOWN)
221 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
228 sym->attr.implicit_type = 1;
234 /******************** Symbol attribute stuff *********************/
236 /* This is a generic conflict-checker. We do this to avoid having a
237 single conflict in two places. */
239 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
240 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
243 check_conflict (symbol_attribute * attr, locus * where)
245 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
246 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
247 *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
248 *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
249 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
250 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
251 *function = "FUNCTION", *subroutine = "SUBROUTINE",
252 *dimension = "DIMENSION";
257 where = &gfc_current_locus;
259 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
266 /* Check for attributes not allowed in a BLOCK DATA. */
267 if (gfc_current_state () == COMP_BLOCK_DATA)
271 if (attr->allocatable)
277 if (attr->access == ACCESS_PRIVATE)
279 if (attr->access == ACCESS_PUBLIC)
281 if (attr->intent != INTENT_UNKNOWN)
287 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
294 conf (pointer, target);
295 conf (pointer, external);
296 conf (pointer, intrinsic);
297 conf (target, external);
298 conf (target, intrinsic);
299 conf (external, dimension); /* See Fortran 95's R504. */
301 conf (external, intrinsic);
302 conf (allocatable, pointer);
303 conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
304 conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
305 conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
306 conf (elemental, recursive);
308 conf (in_common, dummy);
309 conf (in_common, allocatable);
310 conf (in_common, result);
311 conf (dummy, result);
313 conf (in_namelist, pointer);
314 conf (in_namelist, allocatable);
316 conf (entry, result);
318 conf (function, subroutine);
320 a1 = gfc_code2string (flavors, attr->flavor);
322 if (attr->in_namelist
323 && attr->flavor != FL_VARIABLE
324 && attr->flavor != FL_UNKNOWN)
331 switch (attr->flavor)
358 if (attr->subroutine)
371 case PROC_ST_FUNCTION:
404 if (attr->intent != INTENT_UNKNOWN)
432 gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where);
440 /* Mark a symbol as referenced. */
443 gfc_set_sym_referenced (gfc_symbol * sym)
445 if (sym->attr.referenced)
448 sym->attr.referenced = 1;
450 /* Remember which order dummy variables are accessed in. */
452 sym->dummy_order = next_dummy_order++;
456 /* Common subroutine called by attribute changing subroutines in order
457 to prevent them from changing a symbol that has been
458 use-associated. Returns zero if it is OK to change the symbol,
462 check_used (symbol_attribute * attr, locus * where)
465 if (attr->use_assoc == 0)
469 where = &gfc_current_locus;
471 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
478 /* Used to prevent changing the attributes of a symbol after it has been
479 used. This check is only done from dummy variable as only these can be
480 used in specification expressions. Applying this to all symbols causes
481 error when we reach the body of a contained function. */
484 check_done (symbol_attribute * attr, locus * where)
487 if (!(attr->dummy && attr->referenced))
491 where = &gfc_current_locus;
493 gfc_error ("Cannot change attributes of symbol at %L"
494 " after it has been used", where);
500 /* Generate an error because of a duplicate attribute. */
503 duplicate_attr (const char *attr, locus * where)
507 where = &gfc_current_locus;
509 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
514 gfc_add_allocatable (symbol_attribute * attr, locus * where)
517 if (check_used (attr, where) || check_done (attr, where))
520 if (attr->allocatable)
522 duplicate_attr ("ALLOCATABLE", where);
526 attr->allocatable = 1;
527 return check_conflict (attr, where);
532 gfc_add_dimension (symbol_attribute * attr, locus * where)
535 if (check_used (attr, where) || check_done (attr, where))
540 duplicate_attr ("DIMENSION", where);
545 return check_conflict (attr, where);
550 gfc_add_external (symbol_attribute * attr, locus * where)
553 if (check_used (attr, where) || check_done (attr, where))
558 duplicate_attr ("EXTERNAL", where);
564 return check_conflict (attr, where);
569 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
572 if (check_used (attr, where) || check_done (attr, where))
577 duplicate_attr ("INTRINSIC", where);
583 return check_conflict (attr, where);
588 gfc_add_optional (symbol_attribute * attr, locus * where)
591 if (check_used (attr, where) || check_done (attr, where))
596 duplicate_attr ("OPTIONAL", where);
601 return check_conflict (attr, where);
606 gfc_add_pointer (symbol_attribute * attr, locus * where)
609 if (check_used (attr, where) || check_done (attr, where))
613 return check_conflict (attr, where);
618 gfc_add_result (symbol_attribute * attr, locus * where)
621 if (check_used (attr, where) || check_done (attr, where))
625 return check_conflict (attr, where);
630 gfc_add_save (symbol_attribute * attr, locus * where)
633 if (check_used (attr, where))
639 ("SAVE attribute at %L cannot be specified in a PURE procedure",
646 duplicate_attr ("SAVE", where);
651 return check_conflict (attr, where);
656 gfc_add_target (symbol_attribute * attr, locus * where)
659 if (check_used (attr, where) || check_done (attr, where))
664 duplicate_attr ("TARGET", where);
669 return check_conflict (attr, where);
674 gfc_add_dummy (symbol_attribute * attr, locus * where)
677 if (check_used (attr, where))
680 /* Duplicate dummy arguments are allow due to ENTRY statements. */
682 return check_conflict (attr, where);
687 gfc_add_in_common (symbol_attribute * attr, locus * where)
690 if (check_used (attr, where) || check_done (attr, where))
693 /* Duplicate attribute already checked for. */
695 if (check_conflict (attr, where) == FAILURE)
698 if (attr->flavor == FL_VARIABLE)
701 return gfc_add_flavor (attr, FL_VARIABLE, where);
706 gfc_add_data (symbol_attribute *attr, locus *where)
709 if (check_used (attr, where))
713 return check_conflict (attr, where);
718 gfc_add_in_namelist (symbol_attribute * attr, locus * where)
721 attr->in_namelist = 1;
722 return check_conflict (attr, where);
727 gfc_add_sequence (symbol_attribute * attr, locus * where)
730 if (check_used (attr, where))
734 return check_conflict (attr, where);
739 gfc_add_elemental (symbol_attribute * attr, locus * where)
742 if (check_used (attr, where) || check_done (attr, where))
746 return check_conflict (attr, where);
751 gfc_add_pure (symbol_attribute * attr, locus * where)
754 if (check_used (attr, where) || check_done (attr, where))
758 return check_conflict (attr, where);
763 gfc_add_recursive (symbol_attribute * attr, locus * where)
766 if (check_used (attr, where) || check_done (attr, where))
770 return check_conflict (attr, where);
775 gfc_add_entry (symbol_attribute * attr, locus * where)
778 if (check_used (attr, where))
783 duplicate_attr ("ENTRY", where);
788 return check_conflict (attr, where);
793 gfc_add_function (symbol_attribute * attr, locus * where)
796 if (attr->flavor != FL_PROCEDURE
797 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
801 return check_conflict (attr, where);
806 gfc_add_subroutine (symbol_attribute * attr, locus * where)
809 if (attr->flavor != FL_PROCEDURE
810 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
813 attr->subroutine = 1;
814 return check_conflict (attr, where);
819 gfc_add_generic (symbol_attribute * attr, locus * where)
822 if (attr->flavor != FL_PROCEDURE
823 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
827 return check_conflict (attr, where);
831 /* Flavors are special because some flavors are not what fortran
832 considers attributes and can be reaffirmed multiple times. */
835 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
838 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
839 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
840 || f == FL_NAMELIST) && check_used (attr, where))
843 if (attr->flavor == f && f == FL_VARIABLE)
846 if (attr->flavor != FL_UNKNOWN)
849 where = &gfc_current_locus;
851 gfc_error ("%s attribute conflicts with %s attribute at %L",
852 gfc_code2string (flavors, attr->flavor),
853 gfc_code2string (flavors, f), where);
860 return check_conflict (attr, where);
865 gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
868 if (check_used (attr, where) || check_done (attr, where))
871 if (attr->flavor != FL_PROCEDURE
872 && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
876 where = &gfc_current_locus;
878 if (attr->proc != PROC_UNKNOWN)
880 gfc_error ("%s procedure at %L is already %s %s procedure",
881 gfc_code2string (procedures, t), where,
882 gfc_article (gfc_code2string (procedures, attr->proc)),
883 gfc_code2string (procedures, attr->proc));
890 /* Statement functions are always scalar and functions. */
891 if (t == PROC_ST_FUNCTION
892 && ((!attr->function && gfc_add_function (attr, where) == FAILURE)
896 return check_conflict (attr, where);
901 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
904 if (check_used (attr, where))
907 if (attr->intent == INTENT_UNKNOWN)
909 attr->intent = intent;
910 return check_conflict (attr, where);
914 where = &gfc_current_locus;
916 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
917 gfc_intent_string (attr->intent),
918 gfc_intent_string (intent), where);
924 /* No checks for use-association in public and private statements. */
927 gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where)
930 if (attr->access == ACCESS_UNKNOWN)
932 attr->access = access;
933 return check_conflict (attr, where);
937 where = &gfc_current_locus;
938 gfc_error ("ACCESS specification at %L was already specified", where);
945 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
946 gfc_formal_arglist * formal, locus * where)
949 if (check_used (&sym->attr, where))
953 where = &gfc_current_locus;
955 if (sym->attr.if_source != IFSRC_UNKNOWN
956 && sym->attr.if_source != IFSRC_DECL)
958 gfc_error ("Symbol '%s' at %L already has an explicit interface",
963 sym->formal = formal;
964 sym->attr.if_source = source;
970 /* Add a type to a symbol. */
973 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
977 /* TODO: This is legal if it is reaffirming an implicit type.
978 if (check_done (&sym->attr, where))
982 where = &gfc_current_locus;
984 if (sym->ts.type != BT_UNKNOWN)
986 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
987 where, gfc_basic_typename (sym->ts.type));
991 flavor = sym->attr.flavor;
993 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
994 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
995 && sym->attr.subroutine)
996 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
998 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1007 /* Clears all attributes. */
1010 gfc_clear_attr (symbol_attribute * attr)
1012 memset (attr, 0, sizeof(symbol_attribute));
1016 /* Check for missing attributes in the new symbol. Currently does
1017 nothing, but it's not clear that it is unnecessary yet. */
1020 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1021 locus * where ATTRIBUTE_UNUSED)
1028 /* Copy an attribute to a symbol attribute, bit by bit. Some
1029 attributes have a lot of side-effects but cannot be present given
1030 where we are called from, so we ignore some bits. */
1033 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1036 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1039 if (src->dimension && gfc_add_dimension (dest, where) == FAILURE)
1041 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1043 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1045 if (src->save && gfc_add_save (dest, where) == FAILURE)
1047 if (src->target && gfc_add_target (dest, where) == FAILURE)
1049 if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
1051 if (src->result && gfc_add_result (dest, where) == FAILURE)
1056 if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE)
1059 if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
1062 if (src->generic && gfc_add_generic (dest, where) == FAILURE)
1064 if (src->function && gfc_add_function (dest, where) == FAILURE)
1066 if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE)
1069 if (src->sequence && gfc_add_sequence (dest, where) == FAILURE)
1071 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1073 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1075 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1078 if (src->flavor != FL_UNKNOWN
1079 && gfc_add_flavor (dest, src->flavor, where) == FAILURE)
1082 if (src->intent != INTENT_UNKNOWN
1083 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1086 if (src->access != ACCESS_UNKNOWN
1087 && gfc_add_access (dest, src->access, where) == FAILURE)
1090 if (gfc_missing_attr (dest, where) == FAILURE)
1093 /* The subroutines that set these bits also cause flavors to be set,
1094 and that has already happened in the original, so don't let to
1099 dest->intrinsic = 1;
1108 /************** Component name management ************/
1110 /* Component names of a derived type form their own little namespaces
1111 that are separate from all other spaces. The space is composed of
1112 a singly linked list of gfc_component structures whose head is
1113 located in the parent symbol. */
1116 /* Add a component name to a symbol. The call fails if the name is
1117 already present. On success, the component pointer is modified to
1118 point to the additional component structure. */
1121 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1123 gfc_component *p, *tail;
1127 for (p = sym->components; p; p = p->next)
1129 if (strcmp (p->name, name) == 0)
1131 gfc_error ("Component '%s' at %C already declared at %L",
1139 /* Allocate new component */
1140 p = gfc_get_component ();
1143 sym->components = p;
1147 strcpy (p->name, name);
1148 p->loc = gfc_current_locus;
1155 /* Recursive function to switch derived types of all symbol in a
1159 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1167 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1168 sym->ts.derived = to;
1170 switch_types (st->left, from, to);
1171 switch_types (st->right, from, to);
1175 /* This subroutine is called when a derived type is used in order to
1176 make the final determination about which version to use. The
1177 standard requires that a type be defined before it is 'used', but
1178 such types can appear in IMPLICIT statements before the actual
1179 definition. 'Using' in this context means declaring a variable to
1180 be that type or using the type constructor.
1182 If a type is used and the components haven't been defined, then we
1183 have to have a derived type in a parent unit. We find the node in
1184 the other namespace and point the symtree node in this namespace to
1185 that node. Further reference to this name point to the correct
1186 node. If we can't find the node in a parent namespace, then have
1189 This subroutine takes a pointer to a symbol node and returns a
1190 pointer to the translated node or NULL for an error. Usually there
1191 is no translation and we return the node we were passed. */
1193 static gfc_symtree *
1194 gfc_use_ha_derived (gfc_symbol * sym)
1201 if (sym->ns->parent == NULL)
1204 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1206 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1210 if (s == NULL || s->attr.flavor != FL_DERIVED)
1213 /* Get rid of symbol sym, translating all references to s. */
1214 for (i = 0; i < GFC_LETTERS; i++)
1216 t = &sym->ns->default_type[i];
1217 if (t->derived == sym)
1221 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1226 /* Unlink from list of modified symbols. */
1227 if (changed_syms == sym)
1228 changed_syms = sym->tlink;
1230 for (p = changed_syms; p; p = p->tlink)
1231 if (p->tlink == sym)
1233 p->tlink = sym->tlink;
1237 switch_types (sym->ns->sym_root, sym, s);
1239 /* TODO: Also have to replace sym -> s in other lists like
1240 namelists, common lists and interface lists. */
1241 gfc_free_symbol (sym);
1246 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1253 gfc_use_derived (gfc_symbol * sym)
1257 if (sym->components != NULL)
1258 return sym; /* Already defined */
1260 st = gfc_use_ha_derived (sym);
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. */
1540 gfc_get_namespace (gfc_namespace * parent)
1544 gfc_intrinsic_op in;
1547 ns = gfc_getmem (sizeof (gfc_namespace));
1548 ns->sym_root = NULL;
1549 ns->uop_root = NULL;
1550 ns->default_access = ACCESS_UNKNOWN;
1551 ns->parent = parent;
1553 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1554 ns->operator_access[in] = ACCESS_UNKNOWN;
1556 /* Initialize default implicit types. */
1557 for (i = 'a'; i <= 'z'; i++)
1559 ns->set_flag[i - 'a'] = 0;
1560 ts = &ns->default_type[i - 'a'];
1562 if (ns->parent != NULL)
1564 /* Copy parent settings */
1565 *ts = ns->parent->default_type[i - 'a'];
1569 if (gfc_option.flag_implicit_none != 0)
1575 if ('i' <= i && i <= 'n')
1577 ts->type = BT_INTEGER;
1578 ts->kind = gfc_default_integer_kind;
1583 ts->kind = gfc_default_real_kind;
1593 /* Comparison function for symtree nodes. */
1596 compare_symtree (void * _st1, void * _st2)
1598 gfc_symtree *st1, *st2;
1600 st1 = (gfc_symtree *) _st1;
1601 st2 = (gfc_symtree *) _st2;
1603 return strcmp (st1->name, st2->name);
1607 /* Allocate a new symtree node and associate it with the new symbol. */
1610 gfc_new_symtree (gfc_symtree ** root, const char *name)
1614 st = gfc_getmem (sizeof (gfc_symtree));
1615 strcpy (st->name, name);
1617 gfc_insert_bbt (root, st, compare_symtree);
1622 /* Delete a symbol from the tree. Does not free the symbol itself! */
1625 delete_symtree (gfc_symtree ** root, const char *name)
1627 gfc_symtree st, *st0;
1629 st0 = gfc_find_symtree (*root, name);
1631 strcpy (st.name, name);
1632 gfc_delete_bbt (root, &st, compare_symtree);
1638 /* Given a root symtree node and a name, try to find the symbol within
1639 the namespace. Returns NULL if the symbol is not found. */
1642 gfc_find_symtree (gfc_symtree * st, const char *name)
1648 c = strcmp (name, st->name);
1652 st = (c < 0) ? st->left : st->right;
1659 /* Given a name find a user operator node, creating it if it doesn't
1660 exist. These are much simpler than symbols because they can't be
1661 ambiguous with one another. */
1664 gfc_get_uop (const char *name)
1669 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1673 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1675 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1676 strcpy (uop->name, name);
1677 uop->access = ACCESS_UNKNOWN;
1678 uop->ns = gfc_current_ns;
1684 /* Given a name find the user operator node. Returns NULL if it does
1688 gfc_find_uop (const char *name, gfc_namespace * ns)
1693 ns = gfc_current_ns;
1695 st = gfc_find_symtree (ns->uop_root, name);
1696 return (st == NULL) ? NULL : st->n.uop;
1700 /* Remove a gfc_symbol structure and everything it points to. */
1703 gfc_free_symbol (gfc_symbol * sym)
1709 gfc_free_array_spec (sym->as);
1711 free_components (sym->components);
1713 gfc_free_expr (sym->value);
1715 gfc_free_namelist (sym->namelist);
1717 gfc_free_namespace (sym->formal_ns);
1719 gfc_free_interface (sym->generic);
1721 gfc_free_formal_arglist (sym->formal);
1727 /* Allocate and initialize a new symbol node. */
1730 gfc_new_symbol (const char *name, gfc_namespace * ns)
1734 p = gfc_getmem (sizeof (gfc_symbol));
1736 gfc_clear_ts (&p->ts);
1737 gfc_clear_attr (&p->attr);
1740 p->declared_at = gfc_current_locus;
1742 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1743 gfc_internal_error ("new_symbol(): Symbol name too long");
1745 strcpy (p->name, name);
1750 /* Generate an error if a symbol is ambiguous. */
1753 ambiguous_symbol (const char *name, gfc_symtree * st)
1756 if (st->n.sym->module[0])
1757 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1758 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
1760 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1761 "from current program unit", name, st->n.sym->name);
1765 /* Search for a symtree starting in the current namespace, resorting to
1766 any parent namespaces if requested by a nonzero parent_flag.
1767 Returns nonzero if the name is ambiguous. */
1770 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
1771 gfc_symtree ** result)
1776 ns = gfc_current_ns;
1780 st = gfc_find_symtree (ns->sym_root, name);
1786 ambiguous_symbol (name, st);
1805 /* Same, but returns the symbol instead. */
1808 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
1809 gfc_symbol ** result)
1814 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
1819 *result = st->n.sym;
1825 /* Save symbol with the information necessary to back it out. */
1828 save_symbol_data (gfc_symbol * sym)
1831 if (sym->new || sym->old_symbol != NULL)
1834 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
1835 *(sym->old_symbol) = *sym;
1837 sym->tlink = changed_syms;
1842 /* Given a name, find a symbol, or create it if it does not exist yet
1843 in the current namespace. If the symbol is found we make sure that
1846 The integer return code indicates
1848 1 The symbol name was ambiguous
1849 2 The name meant to be established was already host associated.
1851 So if the return value is nonzero, then an error was issued. */
1854 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
1859 /* This doesn't usually happen during resolution. */
1861 ns = gfc_current_ns;
1863 /* Try to find the symbol in ns. */
1864 st = gfc_find_symtree (ns->sym_root, name);
1868 /* If not there, create a new symbol. */
1869 p = gfc_new_symbol (name, ns);
1871 /* Add to the list of tentative symbols. */
1872 p->old_symbol = NULL;
1873 p->tlink = changed_syms;
1878 st = gfc_new_symtree (&ns->sym_root, name);
1885 /* Make sure the existing symbol is OK. */
1888 ambiguous_symbol (name, st);
1894 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
1896 /* Symbol is from another namespace. */
1897 gfc_error ("Symbol '%s' at %C has already been host associated",
1904 /* Copy in case this symbol is changed. */
1905 save_symbol_data (p);
1914 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
1920 i = gfc_get_sym_tree (name, ns, &st);
1925 *result = st->n.sym;
1932 /* Subroutine that searches for a symbol, creating it if it doesn't
1933 exist, but tries to host-associate the symbol if possible. */
1936 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
1941 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1944 save_symbol_data (st->n.sym);
1950 if (gfc_current_ns->parent != NULL)
1952 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
1963 return gfc_get_sym_tree (name, gfc_current_ns, result);
1968 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
1973 i = gfc_get_ha_sym_tree (name, &st);
1976 *result = st->n.sym;
1983 /* Return true if both symbols could refer to the same data object. Does
1984 not take account of aliasing due to equivalence statements. */
1987 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
1989 /* Aliasing isn't possible if the symbols have different base types. */
1990 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
1993 /* Pointers can point to other pointers, target objects and allocatable
1994 objects. Two allocatable objects cannot share the same storage. */
1995 if (lsym->attr.pointer
1996 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
1998 if (lsym->attr.target && rsym->attr.pointer)
2000 if (lsym->attr.allocatable && rsym->attr.pointer)
2007 /* Undoes all the changes made to symbols in the current statement.
2008 This subroutine is made simpler due to the fact that attributes are
2009 never removed once added. */
2012 gfc_undo_symbols (void)
2014 gfc_symbol *p, *q, *old;
2016 for (p = changed_syms; p; p = q)
2022 /* Symbol was new. */
2023 delete_symtree (&p->ns->sym_root, p->name);
2027 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2029 gfc_free_symbol (p);
2033 /* Restore previous state of symbol. Just copy simple stuff. */
2035 old = p->old_symbol;
2037 p->ts.type = old->ts.type;
2038 p->ts.kind = old->ts.kind;
2040 p->attr = old->attr;
2042 if (p->value != old->value)
2044 gfc_free_expr (old->value);
2048 if (p->as != old->as)
2051 gfc_free_array_spec (p->as);
2055 p->generic = old->generic;
2056 p->component_access = old->component_access;
2058 if (p->namelist != NULL && old->namelist == NULL)
2060 gfc_free_namelist (p->namelist);
2066 if (p->namelist_tail != old->namelist_tail)
2068 gfc_free_namelist (old->namelist_tail);
2069 old->namelist_tail->next = NULL;
2073 p->namelist_tail = old->namelist_tail;
2075 if (p->formal != old->formal)
2077 gfc_free_formal_arglist (p->formal);
2078 p->formal = old->formal;
2081 gfc_free (p->old_symbol);
2082 p->old_symbol = NULL;
2086 changed_syms = NULL;
2090 /* Makes the changes made in the current statement permanent-- gets
2091 rid of undo information. */
2094 gfc_commit_symbols (void)
2098 for (p = changed_syms; p; p = q)
2105 if (p->old_symbol != NULL)
2107 gfc_free (p->old_symbol);
2108 p->old_symbol = NULL;
2112 changed_syms = NULL;
2116 /* Recursive function that deletes an entire tree and all the common
2117 head structures it points to. */
2120 free_common_tree (gfc_symtree * common_tree)
2122 if (common_tree == NULL)
2125 free_common_tree (common_tree->left);
2126 free_common_tree (common_tree->right);
2128 gfc_free (common_tree);
2132 /* Recursive function that deletes an entire tree and all the user
2133 operator nodes that it contains. */
2136 free_uop_tree (gfc_symtree * uop_tree)
2139 if (uop_tree == NULL)
2142 free_uop_tree (uop_tree->left);
2143 free_uop_tree (uop_tree->right);
2145 gfc_free_interface (uop_tree->n.uop->operator);
2147 gfc_free (uop_tree->n.uop);
2148 gfc_free (uop_tree);
2152 /* Recursive function that deletes an entire tree and all the symbols
2153 that it contains. */
2156 free_sym_tree (gfc_symtree * sym_tree)
2161 if (sym_tree == NULL)
2164 free_sym_tree (sym_tree->left);
2165 free_sym_tree (sym_tree->right);
2167 sym = sym_tree->n.sym;
2171 gfc_internal_error ("free_sym_tree(): Negative refs");
2173 if (sym->formal_ns != NULL && sym->refs == 1)
2175 /* As formal_ns contains a reference to sym, delete formal_ns just
2176 before the deletion of sym. */
2177 ns = sym->formal_ns;
2178 sym->formal_ns = NULL;
2179 gfc_free_namespace (ns);
2181 else if (sym->refs == 0)
2183 /* Go ahead and delete the symbol. */
2184 gfc_free_symbol (sym);
2187 gfc_free (sym_tree);
2191 /* Free a namespace structure and everything below it. Interface
2192 lists associated with intrinsic operators are not freed. These are
2193 taken care of when a specific name is freed. */
2196 gfc_free_namespace (gfc_namespace * ns)
2198 gfc_charlen *cl, *cl2;
2199 gfc_namespace *p, *q;
2208 gcc_assert (ns->refs == 0);
2210 gfc_free_statements (ns->code);
2212 free_sym_tree (ns->sym_root);
2213 free_uop_tree (ns->uop_root);
2214 free_common_tree (ns->common_root);
2216 for (cl = ns->cl_list; cl; cl = cl2)
2219 gfc_free_expr (cl->length);
2223 free_st_labels (ns->st_labels);
2225 gfc_free_equiv (ns->equiv);
2227 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2228 gfc_free_interface (ns->operator[i]);
2230 gfc_free_data (ns->data);
2234 /* Recursively free any contained namespaces. */
2240 gfc_free_namespace (q);
2246 gfc_symbol_init_2 (void)
2249 gfc_current_ns = gfc_get_namespace (NULL);
2254 gfc_symbol_done_2 (void)
2257 gfc_free_namespace (gfc_current_ns);
2258 gfc_current_ns = NULL;
2262 /* Clear mark bits from symbol nodes associated with a symtree node. */
2265 clear_sym_mark (gfc_symtree * st)
2268 st->n.sym->mark = 0;
2272 /* Recursively traverse the symtree nodes. */
2275 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2281 gfc_traverse_symtree (st->left, func);
2282 gfc_traverse_symtree (st->right, func);
2287 /* Recursive namespace traversal function. */
2290 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2296 if (st->n.sym->mark == 0)
2297 (*func) (st->n.sym);
2298 st->n.sym->mark = 1;
2300 traverse_ns (st->left, func);
2301 traverse_ns (st->right, func);
2305 /* Call a given function for all symbols in the namespace. We take
2306 care that each gfc_symbol node is called exactly once. */
2309 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2312 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2314 traverse_ns (ns->sym_root, func);
2318 /* Given a symbol, mark it as SAVEd if it is allowed. */
2321 save_symbol (gfc_symbol * sym)
2324 if (sym->attr.use_assoc)
2327 if (sym->attr.in_common
2329 || sym->attr.flavor != FL_VARIABLE)
2332 gfc_add_save (&sym->attr, &sym->declared_at);
2336 /* Mark those symbols which can be SAVEd as such. */
2339 gfc_save_all (gfc_namespace * ns)
2342 gfc_traverse_ns (ns, save_symbol);
2347 /* Make sure that no changes to symbols are pending. */
2350 gfc_symbol_state(void) {
2352 if (changed_syms != NULL)
2353 gfc_internal_error("Symbol changes still pending!");
2358 /************** Global symbol handling ************/
2361 /* Search a tree for the global symbol. */
2364 gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
2370 if (strcmp (symbol->name, name) == 0)
2373 s = gfc_find_gsymbol (symbol->left, name);
2377 s = gfc_find_gsymbol (symbol->right, name);
2385 /* Compare two global symbols. Used for managing the BB tree. */
2388 gsym_compare (void * _s1, void * _s2)
2390 gfc_gsymbol *s1, *s2;
2392 s1 = (gfc_gsymbol *)_s1;
2393 s2 = (gfc_gsymbol *)_s2;
2394 return strcmp(s1->name, s2->name);
2398 /* Get a global symbol, creating it if it doesn't exist. */
2401 gfc_get_gsymbol (char *name)
2405 s = gfc_find_gsymbol (gfc_gsym_root, name);
2409 s = gfc_getmem (sizeof (gfc_gsymbol));
2410 s->type = GSYM_UNKNOWN;
2411 strcpy (s->name, name);
2413 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);