1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
38 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
39 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
40 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
44 const mstring procedures[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
47 minit ("MODULE-PROC", PROC_MODULE),
48 minit ("INTERNAL-PROC", PROC_INTERNAL),
49 minit ("DUMMY-PROC", PROC_DUMMY),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
56 const mstring intents[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
59 minit ("IN", INTENT_IN),
60 minit ("OUT", INTENT_OUT),
61 minit ("INOUT", INTENT_INOUT),
65 const mstring access_types[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
68 minit ("PUBLIC", ACCESS_PUBLIC),
69 minit ("PRIVATE", ACCESS_PRIVATE),
73 const mstring ifsrc_types[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN),
76 minit ("DECL", IFSRC_DECL),
77 minit ("BODY", IFSRC_IFBODY),
78 minit ("USAGE", IFSRC_USAGE)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order = 1;
88 gfc_namespace *gfc_current_ns;
90 gfc_gsymbol *gfc_gsym_root = NULL;
92 static gfc_symbol *changed_syms = NULL;
95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
97 /* The following static variable indicates whether a particular element has
98 been explicitly set or not. */
100 static int new_flag[GFC_LETTERS];
103 /* Handle a correctly parsed IMPLICIT NONE. */
106 gfc_set_implicit_none (void)
110 if (gfc_current_ns->seen_implicit_none)
112 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
116 gfc_current_ns->seen_implicit_none = 1;
118 for (i = 0; i < GFC_LETTERS; i++)
120 gfc_clear_ts (&gfc_current_ns->default_type[i]);
121 gfc_current_ns->set_flag[i] = 1;
126 /* Reset the implicit range flags. */
129 gfc_clear_new_implicit (void)
133 for (i = 0; i < GFC_LETTERS; i++)
138 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
141 gfc_add_new_implicit_range (int c1, int c2)
148 for (i = c1; i <= c2; i++)
152 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
165 the new implicit types back into the existing types will work. */
168 gfc_merge_new_implicit (gfc_typespec * ts)
172 if (gfc_current_ns->seen_implicit_none)
174 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
178 for (i = 0; i < GFC_LETTERS; i++)
183 if (gfc_current_ns->set_flag[i])
185 gfc_error ("Letter %c already has an IMPLICIT type at %C",
189 gfc_current_ns->default_type[i] = *ts;
190 gfc_current_ns->set_flag[i] = 1;
197 /* Given a symbol, return a pointer to the typespec for its default type. */
200 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
204 letter = sym->name[0];
206 if (gfc_option.flag_allow_leading_underscore && letter == '_')
207 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
208 "gfortran developers, and should not be used for "
209 "implicitly typed variables");
211 if (letter < 'a' || letter > 'z')
212 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
217 return &ns->default_type[letter - 'a'];
221 /* Given a pointer to a symbol, set its type according to the first
222 letter of its name. Fails if the letter in question has no default
226 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
230 if (sym->ts.type != BT_UNKNOWN)
231 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
233 ts = gfc_get_default_type (sym, ns);
235 if (ts->type == BT_UNKNOWN)
237 if (error_flag && !sym->attr.untyped)
239 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
240 sym->name, &sym->declared_at);
241 sym->attr.untyped = 1; /* Ensure we only give an error once. */
248 sym->attr.implicit_type = 1;
254 /******************** Symbol attribute stuff *********************/
256 /* This is a generic conflict-checker. We do this to avoid having a
257 single conflict in two places. */
259 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
260 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
261 #define conf_std(a, b, std) if (attr->a && attr->b)\
270 check_conflict (symbol_attribute * attr, const char * name, locus * where)
272 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
273 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
274 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
275 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
276 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
277 *private = "PRIVATE", *recursive = "RECURSIVE",
278 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
279 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
280 *function = "FUNCTION", *subroutine = "SUBROUTINE",
281 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
282 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
283 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
284 *volatile_ = "VOLATILE", *protected = "PROTECTED";
285 static const char *threadprivate = "THREADPRIVATE";
291 where = &gfc_current_locus;
293 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
297 standard = GFC_STD_F2003;
301 /* Check for attributes not allowed in a BLOCK DATA. */
302 if (gfc_current_state () == COMP_BLOCK_DATA)
306 if (attr->in_namelist)
308 if (attr->allocatable)
314 if (attr->access == ACCESS_PRIVATE)
316 if (attr->access == ACCESS_PUBLIC)
318 if (attr->intent != INTENT_UNKNOWN)
324 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
331 conf (dummy, intrinsic);
333 conf (dummy, threadprivate);
334 conf (pointer, target);
335 conf (pointer, external);
336 conf (pointer, intrinsic);
337 conf (pointer, elemental);
338 conf (allocatable, elemental);
340 conf (target, external);
341 conf (target, intrinsic);
342 conf (external, dimension); /* See Fortran 95's R504. */
344 conf (external, intrinsic);
346 if (attr->if_source || attr->contained)
348 conf (external, subroutine);
349 conf (external, function);
352 conf (allocatable, pointer);
353 conf_std (allocatable, dummy, GFC_STD_F2003);
354 conf_std (allocatable, function, GFC_STD_F2003);
355 conf_std (allocatable, result, GFC_STD_F2003);
356 conf (elemental, recursive);
358 conf (in_common, dummy);
359 conf (in_common, allocatable);
360 conf (in_common, result);
361 conf (in_common, save);
364 conf (dummy, result);
366 conf (in_equivalence, use_assoc);
367 conf (in_equivalence, dummy);
368 conf (in_equivalence, target);
369 conf (in_equivalence, pointer);
370 conf (in_equivalence, function);
371 conf (in_equivalence, result);
372 conf (in_equivalence, entry);
373 conf (in_equivalence, allocatable);
374 conf (in_equivalence, threadprivate);
376 conf (in_namelist, pointer);
377 conf (in_namelist, allocatable);
379 conf (entry, result);
381 conf (function, subroutine);
383 /* Cray pointer/pointee conflicts. */
384 conf (cray_pointer, cray_pointee);
385 conf (cray_pointer, dimension);
386 conf (cray_pointer, pointer);
387 conf (cray_pointer, target);
388 conf (cray_pointer, allocatable);
389 conf (cray_pointer, external);
390 conf (cray_pointer, intrinsic);
391 conf (cray_pointer, in_namelist);
392 conf (cray_pointer, function);
393 conf (cray_pointer, subroutine);
394 conf (cray_pointer, entry);
396 conf (cray_pointee, allocatable);
397 conf (cray_pointee, intent);
398 conf (cray_pointee, optional);
399 conf (cray_pointee, dummy);
400 conf (cray_pointee, target);
401 conf (cray_pointee, intrinsic);
402 conf (cray_pointee, pointer);
403 conf (cray_pointee, entry);
404 conf (cray_pointee, in_common);
405 conf (cray_pointee, in_equivalence);
406 conf (cray_pointee, threadprivate);
409 conf (data, function);
411 conf (data, allocatable);
412 conf (data, use_assoc);
414 conf (protected, intrinsic)
415 conf (protected, external)
416 conf (protected, in_common)
418 conf (value, pointer)
419 conf (value, allocatable)
420 conf (value, subroutine)
421 conf (value, function)
422 conf (value, volatile_)
423 conf (value, dimension)
424 conf (value, external)
426 if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
429 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
433 conf (volatile_, intrinsic)
434 conf (volatile_, external)
436 if (attr->volatile_ && attr->intent == INTENT_IN)
443 a1 = gfc_code2string (flavors, attr->flavor);
445 if (attr->in_namelist
446 && attr->flavor != FL_VARIABLE
447 && attr->flavor != FL_UNKNOWN)
454 switch (attr->flavor)
475 conf2 (threadprivate);
486 if (attr->subroutine)
495 conf2(threadprivate);
500 case PROC_ST_FUNCTION:
513 conf2 (threadprivate);
534 conf2 (threadprivate);
536 if (attr->intent != INTENT_UNKNOWN)
559 conf2 (threadprivate);
570 gfc_error ("%s attribute conflicts with %s attribute at %L",
573 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
574 a1, a2, name, where);
581 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
582 "with %s attribute at %L", a1, a2,
587 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
588 "with %s attribute in '%s' at %L",
589 a1, a2, name, where);
598 /* Mark a symbol as referenced. */
601 gfc_set_sym_referenced (gfc_symbol * sym)
603 if (sym->attr.referenced)
606 sym->attr.referenced = 1;
608 /* Remember which order dummy variables are accessed in. */
610 sym->dummy_order = next_dummy_order++;
614 /* Common subroutine called by attribute changing subroutines in order
615 to prevent them from changing a symbol that has been
616 use-associated. Returns zero if it is OK to change the symbol,
620 check_used (symbol_attribute * attr, const char * name, locus * where)
623 if (attr->use_assoc == 0)
627 where = &gfc_current_locus;
630 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
633 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
640 /* Generate an error because of a duplicate attribute. */
643 duplicate_attr (const char *attr, locus * where)
647 where = &gfc_current_locus;
649 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
652 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
655 gfc_add_attribute (symbol_attribute * attr, locus * where)
657 if (check_used (attr, NULL, where))
660 return check_conflict (attr, NULL, where);
664 gfc_add_allocatable (symbol_attribute * attr, locus * where)
667 if (check_used (attr, NULL, where))
670 if (attr->allocatable)
672 duplicate_attr ("ALLOCATABLE", where);
676 attr->allocatable = 1;
677 return check_conflict (attr, NULL, where);
682 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
685 if (check_used (attr, name, where))
690 duplicate_attr ("DIMENSION", where);
695 return check_conflict (attr, name, where);
700 gfc_add_external (symbol_attribute * attr, locus * where)
703 if (check_used (attr, NULL, where))
708 duplicate_attr ("EXTERNAL", where);
714 return check_conflict (attr, NULL, where);
719 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
722 if (check_used (attr, NULL, where))
727 duplicate_attr ("INTRINSIC", where);
733 return check_conflict (attr, NULL, where);
738 gfc_add_optional (symbol_attribute * attr, locus * where)
741 if (check_used (attr, NULL, where))
746 duplicate_attr ("OPTIONAL", where);
751 return check_conflict (attr, NULL, where);
756 gfc_add_pointer (symbol_attribute * attr, locus * where)
759 if (check_used (attr, NULL, where))
763 return check_conflict (attr, NULL, where);
768 gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
771 if (check_used (attr, NULL, where))
774 attr->cray_pointer = 1;
775 return check_conflict (attr, NULL, where);
780 gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
783 if (check_used (attr, NULL, where))
786 if (attr->cray_pointee)
788 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
789 " statements", where);
793 attr->cray_pointee = 1;
794 return check_conflict (attr, NULL, where);
798 gfc_add_protected (symbol_attribute * attr, const char *name, locus * where)
800 if (check_used (attr, name, where))
805 if (gfc_notify_std (GFC_STD_LEGACY,
806 "Duplicate PROTECTED attribute specified at %L",
813 return check_conflict (attr, name, where);
817 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
820 if (check_used (attr, name, where))
824 return check_conflict (attr, name, where);
829 gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
832 if (check_used (attr, name, where))
838 ("SAVE attribute at %L cannot be specified in a PURE procedure",
845 if (gfc_notify_std (GFC_STD_LEGACY,
846 "Duplicate SAVE attribute specified at %L",
853 return check_conflict (attr, name, where);
857 gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
860 if (check_used (attr, name, where))
865 if (gfc_notify_std (GFC_STD_LEGACY,
866 "Duplicate VALUE attribute specified at %L",
873 return check_conflict (attr, name, where);
877 gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
879 /* No check_used needed as 11.2.1 of the F2003 standard allows
880 that the local identifier made accessible by a use statement can be
881 given a VOLATILE attribute. */
883 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
884 if (gfc_notify_std (GFC_STD_LEGACY,
885 "Duplicate VOLATILE attribute specified at %L", where)
890 attr->volatile_ns = gfc_current_ns;
891 return check_conflict (attr, name, where);
896 gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where)
898 if (check_used (attr, name, where))
901 if (attr->threadprivate)
903 duplicate_attr ("THREADPRIVATE", where);
907 attr->threadprivate = 1;
908 return check_conflict (attr, name, where);
913 gfc_add_target (symbol_attribute * attr, locus * where)
916 if (check_used (attr, NULL, where))
921 duplicate_attr ("TARGET", where);
926 return check_conflict (attr, NULL, where);
931 gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
934 if (check_used (attr, name, where))
937 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
939 return check_conflict (attr, name, where);
944 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
947 if (check_used (attr, name, where))
950 /* Duplicate attribute already checked for. */
952 if (check_conflict (attr, name, where) == FAILURE)
955 if (attr->flavor == FL_VARIABLE)
958 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
962 gfc_add_in_equivalence (symbol_attribute * attr, const char *name, locus * where)
965 /* Duplicate attribute already checked for. */
966 attr->in_equivalence = 1;
967 if (check_conflict (attr, name, where) == FAILURE)
970 if (attr->flavor == FL_VARIABLE)
973 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
978 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
981 if (check_used (attr, name, where))
985 return check_conflict (attr, name, where);
990 gfc_add_in_namelist (symbol_attribute * attr, const char *name,
994 attr->in_namelist = 1;
995 return check_conflict (attr, name, where);
1000 gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
1003 if (check_used (attr, name, where))
1007 return check_conflict (attr, name, where);
1012 gfc_add_elemental (symbol_attribute * attr, locus * where)
1015 if (check_used (attr, NULL, where))
1018 attr->elemental = 1;
1019 return check_conflict (attr, NULL, where);
1024 gfc_add_pure (symbol_attribute * attr, locus * where)
1027 if (check_used (attr, NULL, where))
1031 return check_conflict (attr, NULL, where);
1036 gfc_add_recursive (symbol_attribute * attr, locus * where)
1039 if (check_used (attr, NULL, where))
1042 attr->recursive = 1;
1043 return check_conflict (attr, NULL, where);
1048 gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
1051 if (check_used (attr, name, where))
1056 duplicate_attr ("ENTRY", where);
1061 return check_conflict (attr, name, where);
1066 gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
1069 if (attr->flavor != FL_PROCEDURE
1070 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1074 return check_conflict (attr, name, where);
1079 gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
1082 if (attr->flavor != FL_PROCEDURE
1083 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1086 attr->subroutine = 1;
1087 return check_conflict (attr, name, where);
1092 gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
1095 if (attr->flavor != FL_PROCEDURE
1096 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1100 return check_conflict (attr, name, where);
1104 /* Flavors are special because some flavors are not what Fortran
1105 considers attributes and can be reaffirmed multiple times. */
1108 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
1112 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1113 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1114 || f == FL_NAMELIST) && check_used (attr, name, where))
1117 if (attr->flavor == f && f == FL_VARIABLE)
1120 if (attr->flavor != FL_UNKNOWN)
1123 where = &gfc_current_locus;
1125 gfc_error ("%s attribute conflicts with %s attribute at %L",
1126 gfc_code2string (flavors, attr->flavor),
1127 gfc_code2string (flavors, f), where);
1134 return check_conflict (attr, name, where);
1139 gfc_add_procedure (symbol_attribute * attr, procedure_type t,
1140 const char *name, locus * where)
1143 if (check_used (attr, name, where))
1146 if (attr->flavor != FL_PROCEDURE
1147 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1151 where = &gfc_current_locus;
1153 if (attr->proc != PROC_UNKNOWN)
1155 gfc_error ("%s procedure at %L is already declared as %s procedure",
1156 gfc_code2string (procedures, t), where,
1157 gfc_code2string (procedures, attr->proc));
1164 /* Statement functions are always scalar and functions. */
1165 if (t == PROC_ST_FUNCTION
1166 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1167 || attr->dimension))
1170 return check_conflict (attr, name, where);
1175 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
1178 if (check_used (attr, NULL, where))
1181 if (attr->intent == INTENT_UNKNOWN)
1183 attr->intent = intent;
1184 return check_conflict (attr, NULL, where);
1188 where = &gfc_current_locus;
1190 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1191 gfc_intent_string (attr->intent),
1192 gfc_intent_string (intent), where);
1198 /* No checks for use-association in public and private statements. */
1201 gfc_add_access (symbol_attribute * attr, gfc_access access,
1202 const char *name, locus * where)
1205 if (attr->access == ACCESS_UNKNOWN)
1207 attr->access = access;
1208 return check_conflict (attr, name, where);
1212 where = &gfc_current_locus;
1213 gfc_error ("ACCESS specification at %L was already specified", where);
1220 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
1221 gfc_formal_arglist * formal, locus * where)
1224 if (check_used (&sym->attr, sym->name, where))
1228 where = &gfc_current_locus;
1230 if (sym->attr.if_source != IFSRC_UNKNOWN
1231 && sym->attr.if_source != IFSRC_DECL)
1233 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1238 sym->formal = formal;
1239 sym->attr.if_source = source;
1245 /* Add a type to a symbol. */
1248 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
1253 where = &gfc_current_locus;
1255 if (sym->ts.type != BT_UNKNOWN)
1257 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1258 if (!(sym->ts.type == ts->type
1259 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1260 || gfc_notification_std (GFC_STD_GNU) == ERROR
1263 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1266 else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1267 gfc_basic_typename (sym->ts.type)) == FAILURE)
1271 flavor = sym->attr.flavor;
1273 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1274 || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1275 && sym->attr.subroutine)
1276 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1278 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1287 /* Clears all attributes. */
1290 gfc_clear_attr (symbol_attribute * attr)
1292 memset (attr, 0, sizeof(symbol_attribute));
1296 /* Check for missing attributes in the new symbol. Currently does
1297 nothing, but it's not clear that it is unnecessary yet. */
1300 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1301 locus * where ATTRIBUTE_UNUSED)
1308 /* Copy an attribute to a symbol attribute, bit by bit. Some
1309 attributes have a lot of side-effects but cannot be present given
1310 where we are called from, so we ignore some bits. */
1313 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1316 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1319 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1321 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1323 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1325 if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1327 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1329 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1331 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1333 if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1335 if (src->target && gfc_add_target (dest, where) == FAILURE)
1337 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1339 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1344 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1347 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1350 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1352 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1354 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1357 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1359 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1361 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1363 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1366 if (src->flavor != FL_UNKNOWN
1367 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1370 if (src->intent != INTENT_UNKNOWN
1371 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1374 if (src->access != ACCESS_UNKNOWN
1375 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1378 if (gfc_missing_attr (dest, where) == FAILURE)
1381 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1383 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1386 /* The subroutines that set these bits also cause flavors to be set,
1387 and that has already happened in the original, so don't let it
1392 dest->intrinsic = 1;
1401 /************** Component name management ************/
1403 /* Component names of a derived type form their own little namespaces
1404 that are separate from all other spaces. The space is composed of
1405 a singly linked list of gfc_component structures whose head is
1406 located in the parent symbol. */
1409 /* Add a component name to a symbol. The call fails if the name is
1410 already present. On success, the component pointer is modified to
1411 point to the additional component structure. */
1414 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1416 gfc_component *p, *tail;
1420 for (p = sym->components; p; p = p->next)
1422 if (strcmp (p->name, name) == 0)
1424 gfc_error ("Component '%s' at %C already declared at %L",
1432 /* Allocate a new component. */
1433 p = gfc_get_component ();
1436 sym->components = p;
1440 p->name = gfc_get_string (name);
1441 p->loc = gfc_current_locus;
1448 /* Recursive function to switch derived types of all symbol in a
1452 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1460 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1461 sym->ts.derived = to;
1463 switch_types (st->left, from, to);
1464 switch_types (st->right, from, to);
1468 /* This subroutine is called when a derived type is used in order to
1469 make the final determination about which version to use. The
1470 standard requires that a type be defined before it is 'used', but
1471 such types can appear in IMPLICIT statements before the actual
1472 definition. 'Using' in this context means declaring a variable to
1473 be that type or using the type constructor.
1475 If a type is used and the components haven't been defined, then we
1476 have to have a derived type in a parent unit. We find the node in
1477 the other namespace and point the symtree node in this namespace to
1478 that node. Further reference to this name point to the correct
1479 node. If we can't find the node in a parent namespace, then we have
1482 This subroutine takes a pointer to a symbol node and returns a
1483 pointer to the translated node or NULL for an error. Usually there
1484 is no translation and we return the node we were passed. */
1487 gfc_use_derived (gfc_symbol * sym)
1494 if (sym->components != NULL)
1495 return sym; /* Already defined. */
1497 if (sym->ns->parent == NULL)
1500 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1502 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1506 if (s == NULL || s->attr.flavor != FL_DERIVED)
1509 /* Get rid of symbol sym, translating all references to s. */
1510 for (i = 0; i < GFC_LETTERS; i++)
1512 t = &sym->ns->default_type[i];
1513 if (t->derived == sym)
1517 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1522 /* Unlink from list of modified symbols. */
1523 gfc_commit_symbol (sym);
1525 switch_types (sym->ns->sym_root, sym, s);
1527 /* TODO: Also have to replace sym -> s in other lists like
1528 namelists, common lists and interface lists. */
1529 gfc_free_symbol (sym);
1534 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1540 /* Given a derived type node and a component name, try to locate the
1541 component structure. Returns the NULL pointer if the component is
1542 not found or the components are private. */
1545 gfc_find_component (gfc_symbol * sym, const char *name)
1552 sym = gfc_use_derived (sym);
1557 for (p = sym->components; p; p = p->next)
1558 if (strcmp (p->name, name) == 0)
1562 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1566 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1568 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1578 /* Given a symbol, free all of the component structures and everything
1582 free_components (gfc_component * p)
1590 gfc_free_array_spec (p->as);
1591 gfc_free_expr (p->initializer);
1598 /* Set component attributes from a standard symbol attribute
1602 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1605 c->dimension = attr->dimension;
1606 c->pointer = attr->pointer;
1607 c->allocatable = attr->allocatable;
1611 /* Get a standard symbol attribute structure given the component
1615 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1618 gfc_clear_attr (attr);
1619 attr->dimension = c->dimension;
1620 attr->pointer = c->pointer;
1621 attr->allocatable = c->allocatable;
1625 /******************** Statement label management ********************/
1627 /* Comparison function for statement labels, used for managing the
1631 compare_st_labels (void * a1, void * b1)
1633 int a = ((gfc_st_label *)a1)->value;
1634 int b = ((gfc_st_label *)b1)->value;
1640 /* Free a single gfc_st_label structure, making sure the tree is not
1641 messed up. This function is called only when some parse error
1645 gfc_free_st_label (gfc_st_label * label)
1650 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1652 if (label->format != NULL)
1653 gfc_free_expr (label->format);
1658 /* Free a whole tree of gfc_st_label structures. */
1661 free_st_labels (gfc_st_label * label)
1666 free_st_labels (label->left);
1667 free_st_labels (label->right);
1669 if (label->format != NULL)
1670 gfc_free_expr (label->format);
1675 /* Given a label number, search for and return a pointer to the label
1676 structure, creating it if it does not exist. */
1679 gfc_get_st_label (int labelno)
1683 /* First see if the label is already in this namespace. */
1684 lp = gfc_current_ns->st_labels;
1687 if (lp->value == labelno)
1690 if (lp->value < labelno)
1696 lp = gfc_getmem (sizeof (gfc_st_label));
1698 lp->value = labelno;
1699 lp->defined = ST_LABEL_UNKNOWN;
1700 lp->referenced = ST_LABEL_UNKNOWN;
1702 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
1708 /* Called when a statement with a statement label is about to be
1709 accepted. We add the label to the list of the current namespace,
1710 making sure it hasn't been defined previously and referenced
1714 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1718 labelno = lp->value;
1720 if (lp->defined != ST_LABEL_UNKNOWN)
1721 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1722 &lp->where, label_locus);
1725 lp->where = *label_locus;
1729 case ST_LABEL_FORMAT:
1730 if (lp->referenced == ST_LABEL_TARGET)
1731 gfc_error ("Label %d at %C already referenced as branch target",
1734 lp->defined = ST_LABEL_FORMAT;
1738 case ST_LABEL_TARGET:
1739 if (lp->referenced == ST_LABEL_FORMAT)
1740 gfc_error ("Label %d at %C already referenced as a format label",
1743 lp->defined = ST_LABEL_TARGET;
1748 lp->defined = ST_LABEL_BAD_TARGET;
1749 lp->referenced = ST_LABEL_BAD_TARGET;
1755 /* Reference a label. Given a label and its type, see if that
1756 reference is consistent with what is known about that label,
1757 updating the unknown state. Returns FAILURE if something goes
1761 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1763 gfc_sl_type label_type;
1770 labelno = lp->value;
1772 if (lp->defined != ST_LABEL_UNKNOWN)
1773 label_type = lp->defined;
1776 label_type = lp->referenced;
1777 lp->where = gfc_current_locus;
1780 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1782 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1787 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1788 && type == ST_LABEL_FORMAT)
1790 gfc_error ("Label %d at %C previously used as branch target", labelno);
1795 lp->referenced = type;
1803 /************** Symbol table management subroutines ****************/
1805 /* Basic details: Fortran 95 requires a potentially unlimited number
1806 of distinct namespaces when compiling a program unit. This case
1807 occurs during a compilation of internal subprograms because all of
1808 the internal subprograms must be read before we can start
1809 generating code for the host.
1811 Given the tricky nature of the Fortran grammar, we must be able to
1812 undo changes made to a symbol table if the current interpretation
1813 of a statement is found to be incorrect. Whenever a symbol is
1814 looked up, we make a copy of it and link to it. All of these
1815 symbols are kept in a singly linked list so that we can commit or
1816 undo the changes at a later time.
1818 A symtree may point to a symbol node outside of its namespace. In
1819 this case, that symbol has been used as a host associated variable
1820 at some previous time. */
1822 /* Allocate a new namespace structure. Copies the implicit types from
1823 PARENT if PARENT_TYPES is set. */
1826 gfc_get_namespace (gfc_namespace * parent, int parent_types)
1830 gfc_intrinsic_op in;
1833 ns = gfc_getmem (sizeof (gfc_namespace));
1834 ns->sym_root = NULL;
1835 ns->uop_root = NULL;
1836 ns->default_access = ACCESS_UNKNOWN;
1837 ns->parent = parent;
1839 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1840 ns->operator_access[in] = ACCESS_UNKNOWN;
1842 /* Initialize default implicit types. */
1843 for (i = 'a'; i <= 'z'; i++)
1845 ns->set_flag[i - 'a'] = 0;
1846 ts = &ns->default_type[i - 'a'];
1848 if (parent_types && ns->parent != NULL)
1850 /* Copy parent settings */
1851 *ts = ns->parent->default_type[i - 'a'];
1855 if (gfc_option.flag_implicit_none != 0)
1861 if ('i' <= i && i <= 'n')
1863 ts->type = BT_INTEGER;
1864 ts->kind = gfc_default_integer_kind;
1869 ts->kind = gfc_default_real_kind;
1879 /* Comparison function for symtree nodes. */
1882 compare_symtree (void * _st1, void * _st2)
1884 gfc_symtree *st1, *st2;
1886 st1 = (gfc_symtree *) _st1;
1887 st2 = (gfc_symtree *) _st2;
1889 return strcmp (st1->name, st2->name);
1893 /* Allocate a new symtree node and associate it with the new symbol. */
1896 gfc_new_symtree (gfc_symtree ** root, const char *name)
1900 st = gfc_getmem (sizeof (gfc_symtree));
1901 st->name = gfc_get_string (name);
1903 gfc_insert_bbt (root, st, compare_symtree);
1908 /* Delete a symbol from the tree. Does not free the symbol itself! */
1911 delete_symtree (gfc_symtree ** root, const char *name)
1913 gfc_symtree st, *st0;
1915 st0 = gfc_find_symtree (*root, name);
1917 st.name = gfc_get_string (name);
1918 gfc_delete_bbt (root, &st, compare_symtree);
1924 /* Given a root symtree node and a name, try to find the symbol within
1925 the namespace. Returns NULL if the symbol is not found. */
1928 gfc_find_symtree (gfc_symtree * st, const char *name)
1934 c = strcmp (name, st->name);
1938 st = (c < 0) ? st->left : st->right;
1945 /* Given a name find a user operator node, creating it if it doesn't
1946 exist. These are much simpler than symbols because they can't be
1947 ambiguous with one another. */
1950 gfc_get_uop (const char *name)
1955 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1959 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1961 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1962 uop->name = gfc_get_string (name);
1963 uop->access = ACCESS_UNKNOWN;
1964 uop->ns = gfc_current_ns;
1970 /* Given a name find the user operator node. Returns NULL if it does
1974 gfc_find_uop (const char *name, gfc_namespace * ns)
1979 ns = gfc_current_ns;
1981 st = gfc_find_symtree (ns->uop_root, name);
1982 return (st == NULL) ? NULL : st->n.uop;
1986 /* Remove a gfc_symbol structure and everything it points to. */
1989 gfc_free_symbol (gfc_symbol * sym)
1995 gfc_free_array_spec (sym->as);
1997 free_components (sym->components);
1999 gfc_free_expr (sym->value);
2001 gfc_free_namelist (sym->namelist);
2003 gfc_free_namespace (sym->formal_ns);
2005 if (!sym->attr.generic_copy)
2006 gfc_free_interface (sym->generic);
2008 gfc_free_formal_arglist (sym->formal);
2014 /* Allocate and initialize a new symbol node. */
2017 gfc_new_symbol (const char *name, gfc_namespace * ns)
2021 p = gfc_getmem (sizeof (gfc_symbol));
2023 gfc_clear_ts (&p->ts);
2024 gfc_clear_attr (&p->attr);
2027 p->declared_at = gfc_current_locus;
2029 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2030 gfc_internal_error ("new_symbol(): Symbol name too long");
2032 p->name = gfc_get_string (name);
2037 /* Generate an error if a symbol is ambiguous. */
2040 ambiguous_symbol (const char *name, gfc_symtree * st)
2043 if (st->n.sym->module)
2044 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2045 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2047 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2048 "from current program unit", name, st->n.sym->name);
2052 /* Search for a symtree starting in the current namespace, resorting to
2053 any parent namespaces if requested by a nonzero parent_flag.
2054 Returns nonzero if the name is ambiguous. */
2057 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
2058 gfc_symtree ** result)
2063 ns = gfc_current_ns;
2067 st = gfc_find_symtree (ns->sym_root, name);
2071 /* Ambiguous generic interfaces are permitted, as long
2072 as the specific interfaces are different. */
2073 if (st->ambiguous && !st->n.sym->attr.generic)
2075 ambiguous_symbol (name, st);
2094 /* Same, but returns the symbol instead. */
2097 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
2098 gfc_symbol ** result)
2103 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2108 *result = st->n.sym;
2114 /* Save symbol with the information necessary to back it out. */
2117 save_symbol_data (gfc_symbol * sym)
2120 if (sym->new || sym->old_symbol != NULL)
2123 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
2124 *(sym->old_symbol) = *sym;
2126 sym->tlink = changed_syms;
2131 /* Given a name, find a symbol, or create it if it does not exist yet
2132 in the current namespace. If the symbol is found we make sure that
2135 The integer return code indicates
2137 1 The symbol name was ambiguous
2138 2 The name meant to be established was already host associated.
2140 So if the return value is nonzero, then an error was issued. */
2143 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
2148 /* This doesn't usually happen during resolution. */
2150 ns = gfc_current_ns;
2152 /* Try to find the symbol in ns. */
2153 st = gfc_find_symtree (ns->sym_root, name);
2157 /* If not there, create a new symbol. */
2158 p = gfc_new_symbol (name, ns);
2160 /* Add to the list of tentative symbols. */
2161 p->old_symbol = NULL;
2162 p->tlink = changed_syms;
2167 st = gfc_new_symtree (&ns->sym_root, name);
2174 /* Make sure the existing symbol is OK. Ambiguous
2175 generic interfaces are permitted, as long as the
2176 specific interfaces are different. */
2177 if (st->ambiguous && !st->n.sym->attr.generic)
2179 ambiguous_symbol (name, st);
2185 if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
2187 /* Symbol is from another namespace. */
2188 gfc_error ("Symbol '%s' at %C has already been host associated",
2195 /* Copy in case this symbol is changed. */
2196 save_symbol_data (p);
2205 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
2211 i = gfc_get_sym_tree (name, ns, &st);
2216 *result = st->n.sym;
2223 /* Subroutine that searches for a symbol, creating it if it doesn't
2224 exist, but tries to host-associate the symbol if possible. */
2227 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
2232 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2235 save_symbol_data (st->n.sym);
2241 if (gfc_current_ns->parent != NULL)
2243 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2254 return gfc_get_sym_tree (name, gfc_current_ns, result);
2259 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
2264 i = gfc_get_ha_sym_tree (name, &st);
2267 *result = st->n.sym;
2274 /* Return true if both symbols could refer to the same data object. Does
2275 not take account of aliasing due to equivalence statements. */
2278 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
2280 /* Aliasing isn't possible if the symbols have different base types. */
2281 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2284 /* Pointers can point to other pointers, target objects and allocatable
2285 objects. Two allocatable objects cannot share the same storage. */
2286 if (lsym->attr.pointer
2287 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2289 if (lsym->attr.target && rsym->attr.pointer)
2291 if (lsym->attr.allocatable && rsym->attr.pointer)
2298 /* Undoes all the changes made to symbols in the current statement.
2299 This subroutine is made simpler due to the fact that attributes are
2300 never removed once added. */
2303 gfc_undo_symbols (void)
2305 gfc_symbol *p, *q, *old;
2307 for (p = changed_syms; p; p = q)
2313 /* Symbol was new. */
2314 delete_symtree (&p->ns->sym_root, p->name);
2318 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2320 gfc_free_symbol (p);
2324 /* Restore previous state of symbol. Just copy simple stuff. */
2326 old = p->old_symbol;
2328 p->ts.type = old->ts.type;
2329 p->ts.kind = old->ts.kind;
2331 p->attr = old->attr;
2333 if (p->value != old->value)
2335 gfc_free_expr (old->value);
2339 if (p->as != old->as)
2342 gfc_free_array_spec (p->as);
2346 p->generic = old->generic;
2347 p->component_access = old->component_access;
2349 if (p->namelist != NULL && old->namelist == NULL)
2351 gfc_free_namelist (p->namelist);
2357 if (p->namelist_tail != old->namelist_tail)
2359 gfc_free_namelist (old->namelist_tail);
2360 old->namelist_tail->next = NULL;
2364 p->namelist_tail = old->namelist_tail;
2366 if (p->formal != old->formal)
2368 gfc_free_formal_arglist (p->formal);
2369 p->formal = old->formal;
2372 gfc_free (p->old_symbol);
2373 p->old_symbol = NULL;
2377 changed_syms = NULL;
2381 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2382 components of old_symbol that might need deallocation are the "allocatables"
2383 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2384 namelist_tail. In case these differ between old_symbol and sym, it's just
2385 because sym->namelist has gotten a few more items. */
2388 free_old_symbol (gfc_symbol * sym)
2390 if (sym->old_symbol == NULL)
2393 if (sym->old_symbol->as != sym->as)
2394 gfc_free_array_spec (sym->old_symbol->as);
2396 if (sym->old_symbol->value != sym->value)
2397 gfc_free_expr (sym->old_symbol->value);
2399 if (sym->old_symbol->formal != sym->formal)
2400 gfc_free_formal_arglist (sym->old_symbol->formal);
2402 gfc_free (sym->old_symbol);
2403 sym->old_symbol = NULL;
2407 /* Makes the changes made in the current statement permanent-- gets
2408 rid of undo information. */
2411 gfc_commit_symbols (void)
2415 for (p = changed_syms; p; p = q)
2422 free_old_symbol (p);
2424 changed_syms = NULL;
2428 /* Makes the changes made in one symbol permanent -- gets rid of undo
2432 gfc_commit_symbol (gfc_symbol * sym)
2436 if (changed_syms == sym)
2437 changed_syms = sym->tlink;
2440 for (p = changed_syms; p; p = p->tlink)
2441 if (p->tlink == sym)
2443 p->tlink = sym->tlink;
2452 free_old_symbol (sym);
2456 /* Recursive function that deletes an entire tree and all the common
2457 head structures it points to. */
2460 free_common_tree (gfc_symtree * common_tree)
2462 if (common_tree == NULL)
2465 free_common_tree (common_tree->left);
2466 free_common_tree (common_tree->right);
2468 gfc_free (common_tree);
2472 /* Recursive function that deletes an entire tree and all the user
2473 operator nodes that it contains. */
2476 free_uop_tree (gfc_symtree * uop_tree)
2479 if (uop_tree == NULL)
2482 free_uop_tree (uop_tree->left);
2483 free_uop_tree (uop_tree->right);
2485 gfc_free_interface (uop_tree->n.uop->operator);
2487 gfc_free (uop_tree->n.uop);
2488 gfc_free (uop_tree);
2492 /* Recursive function that deletes an entire tree and all the symbols
2493 that it contains. */
2496 free_sym_tree (gfc_symtree * sym_tree)
2501 if (sym_tree == NULL)
2504 free_sym_tree (sym_tree->left);
2505 free_sym_tree (sym_tree->right);
2507 sym = sym_tree->n.sym;
2511 gfc_internal_error ("free_sym_tree(): Negative refs");
2513 if (sym->formal_ns != NULL && sym->refs == 1)
2515 /* As formal_ns contains a reference to sym, delete formal_ns just
2516 before the deletion of sym. */
2517 ns = sym->formal_ns;
2518 sym->formal_ns = NULL;
2519 gfc_free_namespace (ns);
2521 else if (sym->refs == 0)
2523 /* Go ahead and delete the symbol. */
2524 gfc_free_symbol (sym);
2527 gfc_free (sym_tree);
2531 /* Free a derived type list. */
2534 gfc_free_dt_list (gfc_dt_list * dt)
2546 /* Free the gfc_equiv_info's. */
2549 gfc_free_equiv_infos (gfc_equiv_info * s)
2553 gfc_free_equiv_infos (s->next);
2558 /* Free the gfc_equiv_lists. */
2561 gfc_free_equiv_lists (gfc_equiv_list * l)
2565 gfc_free_equiv_lists (l->next);
2566 gfc_free_equiv_infos (l->equiv);
2571 /* Free a namespace structure and everything below it. Interface
2572 lists associated with intrinsic operators are not freed. These are
2573 taken care of when a specific name is freed. */
2576 gfc_free_namespace (gfc_namespace * ns)
2578 gfc_charlen *cl, *cl2;
2579 gfc_namespace *p, *q;
2588 gcc_assert (ns->refs == 0);
2590 gfc_free_statements (ns->code);
2592 free_sym_tree (ns->sym_root);
2593 free_uop_tree (ns->uop_root);
2594 free_common_tree (ns->common_root);
2596 for (cl = ns->cl_list; cl; cl = cl2)
2599 gfc_free_expr (cl->length);
2603 free_st_labels (ns->st_labels);
2605 gfc_free_equiv (ns->equiv);
2606 gfc_free_equiv_lists (ns->equiv_lists);
2608 gfc_free_dt_list (ns->derived_types);
2610 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2611 gfc_free_interface (ns->operator[i]);
2613 gfc_free_data (ns->data);
2617 /* Recursively free any contained namespaces. */
2623 gfc_free_namespace (q);
2629 gfc_symbol_init_2 (void)
2632 gfc_current_ns = gfc_get_namespace (NULL, 0);
2637 gfc_symbol_done_2 (void)
2640 gfc_free_namespace (gfc_current_ns);
2641 gfc_current_ns = NULL;
2645 /* Clear mark bits from symbol nodes associated with a symtree node. */
2648 clear_sym_mark (gfc_symtree * st)
2651 st->n.sym->mark = 0;
2655 /* Recursively traverse the symtree nodes. */
2658 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2664 gfc_traverse_symtree (st->left, func);
2665 gfc_traverse_symtree (st->right, func);
2670 /* Recursive namespace traversal function. */
2673 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2679 if (st->n.sym->mark == 0)
2680 (*func) (st->n.sym);
2681 st->n.sym->mark = 1;
2683 traverse_ns (st->left, func);
2684 traverse_ns (st->right, func);
2688 /* Call a given function for all symbols in the namespace. We take
2689 care that each gfc_symbol node is called exactly once. */
2692 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2695 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2697 traverse_ns (ns->sym_root, func);
2701 /* Return TRUE if the symbol is an automatic variable. */
2703 gfc_is_var_automatic (gfc_symbol * sym)
2705 /* Pointer and allocatable variables are never automatic. */
2706 if (sym->attr.pointer || sym->attr.allocatable)
2708 /* Check for arrays with non-constant size. */
2709 if (sym->attr.dimension && sym->as
2710 && !gfc_is_compile_time_shape (sym->as))
2712 /* Check for non-constant length character variables. */
2713 if (sym->ts.type == BT_CHARACTER
2715 && !gfc_is_constant_expr (sym->ts.cl->length))
2720 /* Given a symbol, mark it as SAVEd if it is allowed. */
2723 save_symbol (gfc_symbol * sym)
2726 if (sym->attr.use_assoc)
2729 if (sym->attr.in_common
2731 || sym->attr.flavor != FL_VARIABLE)
2733 /* Automatic objects are not saved. */
2734 if (gfc_is_var_automatic (sym))
2736 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2740 /* Mark those symbols which can be SAVEd as such. */
2743 gfc_save_all (gfc_namespace * ns)
2746 gfc_traverse_ns (ns, save_symbol);
2751 /* Make sure that no changes to symbols are pending. */
2754 gfc_symbol_state(void) {
2756 if (changed_syms != NULL)
2757 gfc_internal_error("Symbol changes still pending!");
2762 /************** Global symbol handling ************/
2765 /* Search a tree for the global symbol. */
2768 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
2774 if (strcmp (symbol->name, name) == 0)
2777 s = gfc_find_gsymbol (symbol->left, name);
2781 s = gfc_find_gsymbol (symbol->right, name);
2789 /* Compare two global symbols. Used for managing the BB tree. */
2792 gsym_compare (void * _s1, void * _s2)
2794 gfc_gsymbol *s1, *s2;
2796 s1 = (gfc_gsymbol *)_s1;
2797 s2 = (gfc_gsymbol *)_s2;
2798 return strcmp(s1->name, s2->name);
2802 /* Get a global symbol, creating it if it doesn't exist. */
2805 gfc_get_gsymbol (const char *name)
2809 s = gfc_find_gsymbol (gfc_gsym_root, name);
2813 s = gfc_getmem (sizeof (gfc_gsymbol));
2814 s->type = GSYM_UNKNOWN;
2815 s->name = gfc_get_string (name);
2817 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);