1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors
[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
39 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
40 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
41 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
45 const mstring procedures
[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
48 minit ("MODULE-PROC", PROC_MODULE
),
49 minit ("INTERNAL-PROC", PROC_INTERNAL
),
50 minit ("DUMMY-PROC", PROC_DUMMY
),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
57 const mstring intents
[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
60 minit ("IN", INTENT_IN
),
61 minit ("OUT", INTENT_OUT
),
62 minit ("INOUT", INTENT_INOUT
),
66 const mstring access_types
[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
69 minit ("PUBLIC", ACCESS_PUBLIC
),
70 minit ("PRIVATE", ACCESS_PRIVATE
),
74 const mstring ifsrc_types
[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN
),
77 minit ("DECL", IFSRC_DECL
),
78 minit ("BODY", IFSRC_IFBODY
),
79 minit ("USAGE", IFSRC_USAGE
)
83 /* This is to make sure the backend generates setup code in the correct
86 static int next_dummy_order
= 1;
89 gfc_namespace
*gfc_current_ns
;
91 static gfc_symbol
*changed_syms
= NULL
;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variables hold the default types set by
97 IMPLICIT statements. We have to store kind information because of
98 IMPLICIT DOUBLE PRECISION statements. IMPLICIT NONE stores a
99 BT_UNKNOWN into all elements. The arrays of flags indicate whether
100 a particular element has been explicitly set or not. */
102 static gfc_typespec new_ts
[GFC_LETTERS
];
103 static int new_flag
[GFC_LETTERS
];
106 /* Handle a correctly parsed IMPLICIT NONE. */
109 gfc_set_implicit_none (void)
113 for (i
= 'a'; i
<= 'z'; i
++)
115 gfc_clear_ts (&gfc_current_ns
->default_type
[i
- 'a']);
116 gfc_current_ns
->set_flag
[i
- 'a'] = 1;
121 /* Sets the implicit types parsed by gfc_match_implicit(). */
124 gfc_set_implicit (void)
128 for (i
= 0; i
< GFC_LETTERS
; i
++)
131 gfc_current_ns
->default_type
[i
] = new_ts
[i
];
132 gfc_current_ns
->set_flag
[i
] = 1;
137 /* Wipe anything a previous IMPLICIT statement may have tried to do. */
138 void gfc_clear_new_implicit (void)
142 for (i
= 0; i
< GFC_LETTERS
; i
++)
144 gfc_clear_ts (&new_ts
[i
]);
151 /* Prepare for a new implicit range. Sets flags in new_flag[] and
152 copies the typespec to new_ts[]. */
154 try gfc_add_new_implicit_range (int c1
, int c2
, gfc_typespec
* ts
)
161 for (i
= c1
; i
<= c2
; i
++)
165 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
178 /* Add a matched implicit range for gfc_set_implicit(). An implicit
179 statement has been fully matched at this point. We now need to
180 check if merging the new implicit types back into the existing
184 gfc_merge_new_implicit (void)
188 for (i
= 0; i
< GFC_LETTERS
; i
++)
191 if (gfc_current_ns
->set_flag
[i
])
193 gfc_error ("Letter %c already has an IMPLICIT type at %C",
203 /* Given a symbol, return a pointer to the typespec for it's default
207 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
211 letter
= sym
->name
[0];
212 if (letter
< 'a' || letter
> 'z')
213 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
218 return &ns
->default_type
[letter
- 'a'];
222 /* Given a pointer to a symbol, set its type according to the first
223 letter of its name. Fails if the letter in question has no default
227 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
231 if (sym
->ts
.type
!= BT_UNKNOWN
)
232 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
234 ts
= gfc_get_default_type (sym
, ns
);
236 if (ts
->type
== BT_UNKNOWN
)
239 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym
->name
,
246 sym
->attr
.implicit_type
= 1;
252 /******************** Symbol attribute stuff *********************/
254 /* This is a generic conflict-checker. We do this to avoid having a
255 single conflict in two places. */
257 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
258 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
261 check_conflict (symbol_attribute
* attr
, locus
* where
)
263 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
264 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
265 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
266 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
267 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
268 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
269 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
270 *dimension
= "DIMENSION";
275 where
= &gfc_current_locus
;
277 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
284 /* Check for attributes not allowed in a BLOCK DATA. */
285 if (gfc_current_state () == COMP_BLOCK_DATA
)
289 if (attr
->allocatable
)
295 if (attr
->access
== ACCESS_PRIVATE
)
297 if (attr
->access
== ACCESS_PUBLIC
)
299 if (attr
->intent
!= INTENT_UNKNOWN
)
305 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
312 conf (pointer
, target
);
313 conf (pointer
, external
);
314 conf (pointer
, intrinsic
);
315 conf (target
, external
);
316 conf (target
, intrinsic
);
317 conf (external
, dimension
); /* See Fortran 95's R504. */
319 conf (external
, intrinsic
);
320 conf (allocatable
, pointer
);
321 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
322 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
323 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
324 conf (elemental
, recursive
);
326 conf (in_common
, dummy
);
327 conf (in_common
, allocatable
);
328 conf (in_common
, result
);
329 conf (dummy
, result
);
331 conf (in_namelist
, pointer
);
332 conf (in_namelist
, allocatable
);
334 conf (entry
, result
);
336 conf (function
, subroutine
);
338 a1
= gfc_code2string (flavors
, attr
->flavor
);
340 if (attr
->in_namelist
341 && attr
->flavor
!= FL_VARIABLE
342 && attr
->flavor
!= FL_UNKNOWN
)
349 switch (attr
->flavor
)
376 if (attr
->subroutine
)
389 case PROC_ST_FUNCTION
:
422 if (attr
->intent
!= INTENT_UNKNOWN
)
450 gfc_error ("%s attribute conflicts with %s attribute at %L", a1
, a2
, where
);
458 /* Mark a symbol as referenced. */
461 gfc_set_sym_referenced (gfc_symbol
* sym
)
463 if (sym
->attr
.referenced
)
466 sym
->attr
.referenced
= 1;
468 /* Remember which order dummy variables are accessed in. */
470 sym
->dummy_order
= next_dummy_order
++;
474 /* Common subroutine called by attribute changing subroutines in order
475 to prevent them from changing a symbol that has been
476 use-associated. Returns zero if it is OK to change the symbol,
480 check_used (symbol_attribute
* attr
, locus
* where
)
483 if (attr
->use_assoc
== 0)
487 where
= &gfc_current_locus
;
489 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
496 /* Used to prevent changing the attributes of a symbol after it has been
497 used. This check is only done from dummy variable as only these can be
498 used in specification expressions. Applying this to all symbols causes
499 error when we reach the body of a contained function. */
502 check_done (symbol_attribute
* attr
, locus
* where
)
505 if (!(attr
->dummy
&& attr
->referenced
))
509 where
= &gfc_current_locus
;
511 gfc_error ("Cannot change attributes of symbol at %L"
512 " after it has been used", where
);
518 /* Generate an error because of a duplicate attribute. */
521 duplicate_attr (const char *attr
, locus
* where
)
525 where
= &gfc_current_locus
;
527 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
532 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
535 if (check_used (attr
, where
) || check_done (attr
, where
))
538 if (attr
->allocatable
)
540 duplicate_attr ("ALLOCATABLE", where
);
544 attr
->allocatable
= 1;
545 return check_conflict (attr
, where
);
550 gfc_add_dimension (symbol_attribute
* attr
, locus
* where
)
553 if (check_used (attr
, where
) || check_done (attr
, where
))
558 duplicate_attr ("DIMENSION", where
);
563 return check_conflict (attr
, where
);
568 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
571 if (check_used (attr
, where
) || check_done (attr
, where
))
576 duplicate_attr ("EXTERNAL", where
);
582 return check_conflict (attr
, where
);
587 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
590 if (check_used (attr
, where
) || check_done (attr
, where
))
595 duplicate_attr ("INTRINSIC", where
);
601 return check_conflict (attr
, where
);
606 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
609 if (check_used (attr
, where
) || check_done (attr
, where
))
614 duplicate_attr ("OPTIONAL", where
);
619 return check_conflict (attr
, where
);
624 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
627 if (check_used (attr
, where
) || check_done (attr
, where
))
631 return check_conflict (attr
, where
);
636 gfc_add_result (symbol_attribute
* attr
, locus
* where
)
639 if (check_used (attr
, where
) || check_done (attr
, where
))
643 return check_conflict (attr
, where
);
648 gfc_add_save (symbol_attribute
* attr
, locus
* where
)
651 if (check_used (attr
, where
))
657 ("SAVE attribute at %L cannot be specified in a PURE procedure",
664 duplicate_attr ("SAVE", where
);
669 return check_conflict (attr
, where
);
674 gfc_add_saved_common (symbol_attribute
* attr
, locus
* where
)
677 if (check_used (attr
, where
))
680 if (attr
->saved_common
)
682 duplicate_attr ("SAVE", where
);
686 attr
->saved_common
= 1;
687 return check_conflict (attr
, where
);
692 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
695 if (check_used (attr
, where
) || check_done (attr
, where
))
700 duplicate_attr ("TARGET", where
);
705 return check_conflict (attr
, where
);
710 gfc_add_dummy (symbol_attribute
* attr
, locus
* where
)
713 if (check_used (attr
, where
))
716 /* Duplicate dummy arguments are allow due to ENTRY statements. */
718 return check_conflict (attr
, where
);
723 gfc_add_common (symbol_attribute
* attr
, locus
* where
)
725 /* TODO: We currently add common blocks into the same namespace as normal
726 variables. This is wrong. Disable the checks below as a temporary
729 if (check_used (attr
, where
) || check_done (attr
, where
))
734 return check_conflict (attr
, where
);
739 gfc_add_in_common (symbol_attribute
* attr
, locus
* where
)
742 if (check_used (attr
, where
) || check_done (attr
, where
))
745 /* Duplicate attribute already checked for. */
747 if (check_conflict (attr
, where
) == FAILURE
)
750 if (attr
->flavor
== FL_VARIABLE
)
753 return gfc_add_flavor (attr
, FL_VARIABLE
, where
);
758 gfc_add_in_namelist (symbol_attribute
* attr
, locus
* where
)
761 attr
->in_namelist
= 1;
762 return check_conflict (attr
, where
);
767 gfc_add_sequence (symbol_attribute
* attr
, locus
* where
)
770 if (check_used (attr
, where
))
774 return check_conflict (attr
, where
);
779 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
782 if (check_used (attr
, where
) || check_done (attr
, where
))
786 return check_conflict (attr
, where
);
791 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
794 if (check_used (attr
, where
) || check_done (attr
, where
))
798 return check_conflict (attr
, where
);
803 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
806 if (check_used (attr
, where
) || check_done (attr
, where
))
810 return check_conflict (attr
, where
);
815 gfc_add_entry (symbol_attribute
* attr
, locus
* where
)
818 if (check_used (attr
, where
))
823 duplicate_attr ("ENTRY", where
);
828 return check_conflict (attr
, where
);
833 gfc_add_function (symbol_attribute
* attr
, locus
* where
)
836 if (attr
->flavor
!= FL_PROCEDURE
837 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
841 return check_conflict (attr
, where
);
846 gfc_add_subroutine (symbol_attribute
* attr
, locus
* where
)
849 if (attr
->flavor
!= FL_PROCEDURE
850 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
853 attr
->subroutine
= 1;
854 return check_conflict (attr
, where
);
859 gfc_add_generic (symbol_attribute
* attr
, locus
* where
)
862 if (attr
->flavor
!= FL_PROCEDURE
863 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
867 return check_conflict (attr
, where
);
871 /* Flavors are special because some flavors are not what fortran
872 considers attributes and can be reaffirmed multiple times. */
875 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, locus
* where
)
878 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
879 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
880 || f
== FL_NAMELIST
) && check_used (attr
, where
))
883 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
886 if (attr
->flavor
!= FL_UNKNOWN
)
889 where
= &gfc_current_locus
;
891 gfc_error ("%s attribute conflicts with %s attribute at %L",
892 gfc_code2string (flavors
, attr
->flavor
),
893 gfc_code2string (flavors
, f
), where
);
900 return check_conflict (attr
, where
);
905 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
, locus
* where
)
908 if (check_used (attr
, where
) || check_done (attr
, where
))
911 if (attr
->flavor
!= FL_PROCEDURE
912 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
916 where
= &gfc_current_locus
;
918 if (attr
->proc
!= PROC_UNKNOWN
)
920 gfc_error ("%s procedure at %L is already %s %s procedure",
921 gfc_code2string (procedures
, t
), where
,
922 gfc_article (gfc_code2string (procedures
, attr
->proc
)),
923 gfc_code2string (procedures
, attr
->proc
));
930 /* Statement functions are always scalar and functions. */
931 if (t
== PROC_ST_FUNCTION
932 && ((!attr
->function
&& gfc_add_function (attr
, where
) == FAILURE
)
936 return check_conflict (attr
, where
);
941 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
944 if (check_used (attr
, where
))
947 if (attr
->intent
== INTENT_UNKNOWN
)
949 attr
->intent
= intent
;
950 return check_conflict (attr
, where
);
954 where
= &gfc_current_locus
;
956 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
957 gfc_intent_string (attr
->intent
),
958 gfc_intent_string (intent
), where
);
964 /* No checks for use-association in public and private statements. */
967 gfc_add_access (symbol_attribute
* attr
, gfc_access access
, locus
* where
)
970 if (attr
->access
== ACCESS_UNKNOWN
)
972 attr
->access
= access
;
973 return check_conflict (attr
, where
);
977 where
= &gfc_current_locus
;
978 gfc_error ("ACCESS specification at %L was already specified", where
);
985 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
986 gfc_formal_arglist
* formal
, locus
* where
)
989 if (check_used (&sym
->attr
, where
))
993 where
= &gfc_current_locus
;
995 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
996 && sym
->attr
.if_source
!= IFSRC_DECL
)
998 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1003 sym
->formal
= formal
;
1004 sym
->attr
.if_source
= source
;
1010 /* Add a type to a symbol. */
1013 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1017 /* TODO: This is legal if it is reaffirming an implicit type.
1018 if (check_done (&sym->attr, where))
1022 where
= &gfc_current_locus
;
1024 if (sym
->ts
.type
!= BT_UNKNOWN
)
1026 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1027 where
, gfc_basic_typename (sym
->ts
.type
));
1031 flavor
= sym
->attr
.flavor
;
1033 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1034 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1035 && sym
->attr
.subroutine
)
1036 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1038 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1047 /* Clears all attributes. */
1050 gfc_clear_attr (symbol_attribute
* attr
)
1053 attr
->allocatable
= 0;
1054 attr
->dimension
= 0;
1056 attr
->intrinsic
= 0;
1066 attr
->use_assoc
= 0;
1067 attr
->in_namelist
= 0;
1069 attr
->in_common
= 0;
1070 attr
->saved_common
= 0;
1072 attr
->subroutine
= 0;
1074 attr
->implicit_type
= 0;
1076 attr
->elemental
= 0;
1078 attr
->recursive
= 0;
1080 attr
->access
= ACCESS_UNKNOWN
;
1081 attr
->intent
= INTENT_UNKNOWN
;
1082 attr
->flavor
= FL_UNKNOWN
;
1083 attr
->proc
= PROC_UNKNOWN
;
1084 attr
->if_source
= IFSRC_UNKNOWN
;
1088 /* Check for missing attributes in the new symbol. Currently does
1089 nothing, but it's not clear that it is unnecessary yet. */
1092 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1093 locus
* where ATTRIBUTE_UNUSED
)
1100 /* Copy an attribute to a symbol attribute, bit by bit. Some
1101 attributes have a lot of side-effects but cannot be present given
1102 where we are called from, so we ignore some bits. */
1105 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1108 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1111 if (src
->dimension
&& gfc_add_dimension (dest
, where
) == FAILURE
)
1113 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1115 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1117 if (src
->save
&& gfc_add_save (dest
, where
) == FAILURE
)
1119 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1121 if (src
->dummy
&& gfc_add_dummy (dest
, where
) == FAILURE
)
1123 if (src
->common
&& gfc_add_common (dest
, where
) == FAILURE
)
1125 if (src
->result
&& gfc_add_result (dest
, where
) == FAILURE
)
1130 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, where
) == FAILURE
)
1133 if (src
->in_common
&& gfc_add_in_common (dest
, where
) == FAILURE
)
1135 if (src
->saved_common
&& gfc_add_saved_common (dest
, where
) == FAILURE
)
1138 if (src
->generic
&& gfc_add_generic (dest
, where
) == FAILURE
)
1140 if (src
->function
&& gfc_add_function (dest
, where
) == FAILURE
)
1142 if (src
->subroutine
&& gfc_add_subroutine (dest
, where
) == FAILURE
)
1145 if (src
->sequence
&& gfc_add_sequence (dest
, where
) == FAILURE
)
1147 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1149 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1151 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1154 if (src
->flavor
!= FL_UNKNOWN
1155 && gfc_add_flavor (dest
, src
->flavor
, where
) == FAILURE
)
1158 if (src
->intent
!= INTENT_UNKNOWN
1159 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1162 if (src
->access
!= ACCESS_UNKNOWN
1163 && gfc_add_access (dest
, src
->access
, where
) == FAILURE
)
1166 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1169 /* The subroutines that set these bits also cause flavors to be set,
1170 and that has already happened in the original, so don't let to
1175 dest
->intrinsic
= 1;
1184 /************** Component name management ************/
1186 /* Component names of a derived type form their own little namespaces
1187 that are separate from all other spaces. The space is composed of
1188 a singly linked list of gfc_component structures whose head is
1189 located in the parent symbol. */
1192 /* Add a component name to a symbol. The call fails if the name is
1193 already present. On success, the component pointer is modified to
1194 point to the additional component structure. */
1197 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1199 gfc_component
*p
, *tail
;
1203 for (p
= sym
->components
; p
; p
= p
->next
)
1205 if (strcmp (p
->name
, name
) == 0)
1207 gfc_error ("Component '%s' at %C already declared at %L",
1215 /* Allocate new component */
1216 p
= gfc_get_component ();
1219 sym
->components
= p
;
1223 strcpy (p
->name
, name
);
1224 p
->loc
= gfc_current_locus
;
1231 /* Recursive function to switch derived types of all symbol in a
1235 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1243 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1244 sym
->ts
.derived
= to
;
1246 switch_types (st
->left
, from
, to
);
1247 switch_types (st
->right
, from
, to
);
1251 /* This subroutine is called when a derived type is used in order to
1252 make the final determination about which version to use. The
1253 standard requires that a type be defined before it is 'used', but
1254 such types can appear in IMPLICIT statements before the actual
1255 definition. 'Using' in this context means declaring a variable to
1256 be that type or using the type constructor.
1258 If a type is used and the components haven't been defined, then we
1259 have to have a derived type in a parent unit. We find the node in
1260 the other namespace and point the symtree node in this namespace to
1261 that node. Further reference to this name point to the correct
1262 node. If we can't find the node in a parent namespace, then have
1265 This subroutine takes a pointer to a symbol node and returns a
1266 pointer to the translated node or NULL for an error. Usually there
1267 is no translation and we return the node we were passed. */
1269 static gfc_symtree
*
1270 gfc_use_ha_derived (gfc_symbol
* sym
)
1277 if (sym
->ns
->parent
== NULL
)
1280 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1282 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1286 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1289 /* Get rid of symbol sym, translating all references to s. */
1290 for (i
= 0; i
< GFC_LETTERS
; i
++)
1292 t
= &sym
->ns
->default_type
[i
];
1293 if (t
->derived
== sym
)
1297 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1302 /* Unlink from list of modified symbols. */
1303 if (changed_syms
== sym
)
1304 changed_syms
= sym
->tlink
;
1306 for (p
= changed_syms
; p
; p
= p
->tlink
)
1307 if (p
->tlink
== sym
)
1309 p
->tlink
= sym
->tlink
;
1313 switch_types (sym
->ns
->sym_root
, sym
, s
);
1315 /* TODO: Also have to replace sym -> s in other lists like
1316 namelists, common lists and interface lists. */
1317 gfc_free_symbol (sym
);
1322 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1329 gfc_use_derived (gfc_symbol
* sym
)
1333 if (sym
->components
!= NULL
)
1334 return sym
; /* Already defined */
1336 st
= gfc_use_ha_derived (sym
);
1344 /* Given a derived type node and a component name, try to locate the
1345 component structure. Returns the NULL pointer if the component is
1346 not found or the components are private. */
1349 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1356 sym
= gfc_use_derived (sym
);
1361 for (p
= sym
->components
; p
; p
= p
->next
)
1362 if (strcmp (p
->name
, name
) == 0)
1366 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1370 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1372 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1382 /* Given a symbol, free all of the component structures and everything
1386 free_components (gfc_component
* p
)
1394 gfc_free_array_spec (p
->as
);
1395 gfc_free_expr (p
->initializer
);
1402 /* Set component attributes from a standard symbol attribute
1406 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1409 c
->dimension
= attr
->dimension
;
1410 c
->pointer
= attr
->pointer
;
1414 /* Get a standard symbol attribute structure given the component
1418 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1421 gfc_clear_attr (attr
);
1422 attr
->dimension
= c
->dimension
;
1423 attr
->pointer
= c
->pointer
;
1427 /******************** Statement label management ********************/
1429 /* Free a single gfc_st_label structure, making sure the list is not
1430 messed up. This function is called only when some parse error
1434 gfc_free_st_label (gfc_st_label
* l
)
1441 (l
->prev
->next
= l
->next
);
1444 (l
->next
->prev
= l
->prev
);
1446 if (l
->format
!= NULL
)
1447 gfc_free_expr (l
->format
);
1451 /* Free a whole list of gfc_st_label structures. */
1454 free_st_labels (gfc_st_label
* l1
)
1461 if (l1
->format
!= NULL
)
1462 gfc_free_expr (l1
->format
);
1468 /* Given a label number, search for and return a pointer to the label
1469 structure, creating it if it does not exist. */
1472 gfc_get_st_label (int labelno
)
1476 /* First see if the label is already in this namespace. */
1477 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1478 if (lp
->value
== labelno
)
1483 lp
= gfc_getmem (sizeof (gfc_st_label
));
1485 lp
->value
= labelno
;
1486 lp
->defined
= ST_LABEL_UNKNOWN
;
1487 lp
->referenced
= ST_LABEL_UNKNOWN
;
1490 lp
->next
= gfc_current_ns
->st_labels
;
1491 if (gfc_current_ns
->st_labels
)
1492 gfc_current_ns
->st_labels
->prev
= lp
;
1493 gfc_current_ns
->st_labels
= lp
;
1499 /* Called when a statement with a statement label is about to be
1500 accepted. We add the label to the list of the current namespace,
1501 making sure it hasn't been defined previously and referenced
1505 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1509 labelno
= lp
->value
;
1511 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1512 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1513 &lp
->where
, label_locus
);
1516 lp
->where
= *label_locus
;
1520 case ST_LABEL_FORMAT
:
1521 if (lp
->referenced
== ST_LABEL_TARGET
)
1522 gfc_error ("Label %d at %C already referenced as branch target",
1525 lp
->defined
= ST_LABEL_FORMAT
;
1529 case ST_LABEL_TARGET
:
1530 if (lp
->referenced
== ST_LABEL_FORMAT
)
1531 gfc_error ("Label %d at %C already referenced as a format label",
1534 lp
->defined
= ST_LABEL_TARGET
;
1539 lp
->defined
= ST_LABEL_BAD_TARGET
;
1540 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1546 /* Reference a label. Given a label and its type, see if that
1547 reference is consistent with what is known about that label,
1548 updating the unknown state. Returns FAILURE if something goes
1552 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1554 gfc_sl_type label_type
;
1561 labelno
= lp
->value
;
1563 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1564 label_type
= lp
->defined
;
1567 label_type
= lp
->referenced
;
1568 lp
->where
= gfc_current_locus
;
1571 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1573 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1578 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1579 && type
== ST_LABEL_FORMAT
)
1581 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1586 lp
->referenced
= type
;
1594 /************** Symbol table management subroutines ****************/
1596 /* Basic details: Fortran 95 requires a potentially unlimited number
1597 of distinct namespaces when compiling a program unit. This case
1598 occurs during a compilation of internal subprograms because all of
1599 the internal subprograms must be read before we can start
1600 generating code for the host.
1602 Given the tricky nature of the fortran grammar, we must be able to
1603 undo changes made to a symbol table if the current interpretation
1604 of a statement is found to be incorrect. Whenever a symbol is
1605 looked up, we make a copy of it and link to it. All of these
1606 symbols are kept in a singly linked list so that we can commit or
1607 undo the changes at a later time.
1609 A symtree may point to a symbol node outside of it's namespace. In
1610 this case, that symbol has been used as a host associated variable
1611 at some previous time. */
1613 /* Allocate a new namespace structure. */
1616 gfc_get_namespace (gfc_namespace
* parent
)
1620 gfc_intrinsic_op in
;
1623 ns
= gfc_getmem (sizeof (gfc_namespace
));
1624 ns
->sym_root
= NULL
;
1625 ns
->uop_root
= NULL
;
1626 ns
->default_access
= ACCESS_UNKNOWN
;
1627 ns
->parent
= parent
;
1629 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1630 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1632 /* Initialize default implicit types. */
1633 for (i
= 'a'; i
<= 'z'; i
++)
1635 ns
->set_flag
[i
- 'a'] = 0;
1636 ts
= &ns
->default_type
[i
- 'a'];
1638 if (ns
->parent
!= NULL
)
1640 /* Copy parent settings */
1641 *ts
= ns
->parent
->default_type
[i
- 'a'];
1645 if (gfc_option
.flag_implicit_none
!= 0)
1651 if ('i' <= i
&& i
<= 'n')
1653 ts
->type
= BT_INTEGER
;
1654 ts
->kind
= gfc_default_integer_kind ();
1659 ts
->kind
= gfc_default_real_kind ();
1667 /* Comparison function for symtree nodes. */
1670 compare_symtree (void * _st1
, void * _st2
)
1672 gfc_symtree
*st1
, *st2
;
1674 st1
= (gfc_symtree
*) _st1
;
1675 st2
= (gfc_symtree
*) _st2
;
1677 return strcmp (st1
->name
, st2
->name
);
1681 /* Allocate a new symtree node and associate it with the new symbol. */
1684 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1688 st
= gfc_getmem (sizeof (gfc_symtree
));
1689 strcpy (st
->name
, name
);
1691 gfc_insert_bbt (root
, st
, compare_symtree
);
1696 /* Delete a symbol from the tree. Does not free the symbol itself! */
1699 delete_symtree (gfc_symtree
** root
, const char *name
)
1701 gfc_symtree st
, *st0
;
1703 st0
= gfc_find_symtree (*root
, name
);
1705 strcpy (st
.name
, name
);
1706 gfc_delete_bbt (root
, &st
, compare_symtree
);
1712 /* Given a root symtree node and a name, try to find the symbol within
1713 the namespace. Returns NULL if the symbol is not found. */
1716 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1722 c
= strcmp (name
, st
->name
);
1726 st
= (c
< 0) ? st
->left
: st
->right
;
1733 /* Given a name find a user operator node, creating it if it doesn't
1734 exist. These are much simpler than symbols because they can't be
1735 ambiguous with one another. */
1738 gfc_get_uop (const char *name
)
1743 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1747 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1749 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1750 strcpy (uop
->name
, name
);
1751 uop
->access
= ACCESS_UNKNOWN
;
1752 uop
->ns
= gfc_current_ns
;
1758 /* Given a name find the user operator node. Returns NULL if it does
1762 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1767 ns
= gfc_current_ns
;
1769 st
= gfc_find_symtree (ns
->uop_root
, name
);
1770 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1774 /* Remove a gfc_symbol structure and everything it points to. */
1777 gfc_free_symbol (gfc_symbol
* sym
)
1783 gfc_free_array_spec (sym
->as
);
1785 free_components (sym
->components
);
1787 gfc_free_expr (sym
->value
);
1789 gfc_free_namelist (sym
->namelist
);
1791 gfc_free_namespace (sym
->formal_ns
);
1793 gfc_free_interface (sym
->generic
);
1795 gfc_free_formal_arglist (sym
->formal
);
1801 /* Allocate and initialize a new symbol node. */
1804 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1808 p
= gfc_getmem (sizeof (gfc_symbol
));
1810 gfc_clear_ts (&p
->ts
);
1811 gfc_clear_attr (&p
->attr
);
1814 p
->declared_at
= gfc_current_locus
;
1816 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1817 gfc_internal_error ("new_symbol(): Symbol name too long");
1819 strcpy (p
->name
, name
);
1824 /* Generate an error if a symbol is ambiguous. */
1827 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1830 if (st
->n
.sym
->module
[0])
1831 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1832 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1834 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1835 "from current program unit", name
, st
->n
.sym
->name
);
1839 /* Search for a symbol starting in the current namespace, resorting to
1840 any parent namespaces if requested by a nonzero parent_flag.
1841 Returns nonzero if the symbol is ambiguous. */
1844 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1845 gfc_symtree
** result
)
1850 ns
= gfc_current_ns
;
1854 st
= gfc_find_symtree (ns
->sym_root
, name
);
1860 ambiguous_symbol (name
, st
);
1880 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1881 gfc_symbol
** result
)
1886 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1891 *result
= st
->n
.sym
;
1897 /* Save symbol with the information necessary to back it out. */
1900 save_symbol_data (gfc_symbol
* sym
)
1903 if (sym
->new || sym
->old_symbol
!= NULL
)
1906 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1907 *(sym
->old_symbol
) = *sym
;
1909 sym
->tlink
= changed_syms
;
1914 /* Given a name, find a symbol, or create it if it does not exist yet
1915 in the current namespace. If the symbol is found we make sure that
1918 The integer return code indicates
1920 1 The symbol name was ambiguous
1921 2 The name meant to be established was already host associated.
1923 So if the return value is nonzero, then an error was issued. */
1926 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1931 /* This doesn't usually happen during resolution. */
1933 ns
= gfc_current_ns
;
1935 /* Try to find the symbol in ns. */
1936 st
= gfc_find_symtree (ns
->sym_root
, name
);
1940 /* If not there, create a new symbol. */
1941 p
= gfc_new_symbol (name
, ns
);
1943 /* Add to the list of tentative symbols. */
1944 p
->old_symbol
= NULL
;
1945 p
->tlink
= changed_syms
;
1950 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1957 /* Make sure the existing symbol is OK. */
1960 ambiguous_symbol (name
, st
);
1966 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1968 /* Symbol is from another namespace. */
1969 gfc_error ("Symbol '%s' at %C has already been host associated",
1976 /* Copy in case this symbol is changed. */
1977 save_symbol_data (p
);
1986 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1992 i
= gfc_get_sym_tree (name
, ns
, &st
);
1997 *result
= st
->n
.sym
;
2004 /* Subroutine that searches for a symbol, creating it if it doesn't
2005 exist, but tries to host-associate the symbol if possible. */
2008 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2013 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2016 save_symbol_data (st
->n
.sym
);
2022 if (gfc_current_ns
->parent
!= NULL
)
2024 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2035 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2040 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2045 i
= gfc_get_ha_sym_tree (name
, &st
);
2048 *result
= st
->n
.sym
;
2055 /* Return true if both symbols could refer to the same data object. Does
2056 not take account of aliasing due to equivalence statements. */
2059 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2061 /* Aliasing isn't possible if the symbols have different base types. */
2062 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2065 /* Pointers can point to other pointers, target objects and allocatable
2066 objects. Two allocatable objects cannot share the same storage. */
2067 if (lsym
->attr
.pointer
2068 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2070 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2072 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2079 /* Undoes all the changes made to symbols in the current statement.
2080 This subroutine is made simpler due to the fact that attributes are
2081 never removed once added. */
2084 gfc_undo_symbols (void)
2086 gfc_symbol
*p
, *q
, *old
;
2088 for (p
= changed_syms
; p
; p
= q
)
2094 /* Symbol was new. */
2095 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2099 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2101 gfc_free_symbol (p
);
2105 /* Restore previous state of symbol. Just copy simple stuff. */
2107 old
= p
->old_symbol
;
2109 p
->ts
.type
= old
->ts
.type
;
2110 p
->ts
.kind
= old
->ts
.kind
;
2112 p
->attr
= old
->attr
;
2114 if (p
->value
!= old
->value
)
2116 gfc_free_expr (old
->value
);
2120 if (p
->as
!= old
->as
)
2123 gfc_free_array_spec (p
->as
);
2127 p
->generic
= old
->generic
;
2128 p
->component_access
= old
->component_access
;
2130 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2132 gfc_free_namelist (p
->namelist
);
2138 if (p
->namelist_tail
!= old
->namelist_tail
)
2140 gfc_free_namelist (old
->namelist_tail
);
2141 old
->namelist_tail
->next
= NULL
;
2145 p
->namelist_tail
= old
->namelist_tail
;
2147 if (p
->formal
!= old
->formal
)
2149 gfc_free_formal_arglist (p
->formal
);
2150 p
->formal
= old
->formal
;
2153 gfc_free (p
->old_symbol
);
2154 p
->old_symbol
= NULL
;
2158 changed_syms
= NULL
;
2162 /* Makes the changes made in the current statement permanent-- gets
2163 rid of undo information. */
2166 gfc_commit_symbols (void)
2170 for (p
= changed_syms
; p
; p
= q
)
2177 if (p
->old_symbol
!= NULL
)
2179 gfc_free (p
->old_symbol
);
2180 p
->old_symbol
= NULL
;
2184 changed_syms
= NULL
;
2188 /* Recursive function that deletes an entire tree and all the user
2189 operator nodes that it contains. */
2192 free_uop_tree (gfc_symtree
* uop_tree
)
2195 if (uop_tree
== NULL
)
2198 free_uop_tree (uop_tree
->left
);
2199 free_uop_tree (uop_tree
->right
);
2201 gfc_free_interface (uop_tree
->n
.uop
->operator);
2203 gfc_free (uop_tree
->n
.uop
);
2204 gfc_free (uop_tree
);
2208 /* Recursive function that deletes an entire tree and all the symbols
2209 that it contains. */
2212 free_sym_tree (gfc_symtree
* sym_tree
)
2217 if (sym_tree
== NULL
)
2220 free_sym_tree (sym_tree
->left
);
2221 free_sym_tree (sym_tree
->right
);
2223 sym
= sym_tree
->n
.sym
;
2227 gfc_internal_error ("free_sym_tree(): Negative refs");
2229 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2231 /* As formal_ns contains a reference to sym, delete formal_ns just
2232 before the deletion of sym. */
2233 ns
= sym
->formal_ns
;
2234 sym
->formal_ns
= NULL
;
2235 gfc_free_namespace (ns
);
2237 else if (sym
->refs
== 0)
2239 /* Go ahead and delete the symbol. */
2240 gfc_free_symbol (sym
);
2243 gfc_free (sym_tree
);
2247 /* Free a namespace structure and everything below it. Interface
2248 lists associated with intrinsic operators are not freed. These are
2249 taken care of when a specific name is freed. */
2252 gfc_free_namespace (gfc_namespace
* ns
)
2254 gfc_charlen
*cl
, *cl2
;
2255 gfc_namespace
*p
, *q
;
2261 gfc_free_statements (ns
->code
);
2263 free_sym_tree (ns
->sym_root
);
2264 free_uop_tree (ns
->uop_root
);
2266 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2269 gfc_free_expr (cl
->length
);
2273 free_st_labels (ns
->st_labels
);
2275 gfc_free_equiv (ns
->equiv
);
2277 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2278 gfc_free_interface (ns
->operator[i
]);
2280 gfc_free_data (ns
->data
);
2284 /* Recursively free any contained namespaces. */
2290 gfc_free_namespace (q
);
2296 gfc_symbol_init_2 (void)
2299 gfc_current_ns
= gfc_get_namespace (NULL
);
2304 gfc_symbol_done_2 (void)
2307 gfc_free_namespace (gfc_current_ns
);
2308 gfc_current_ns
= NULL
;
2312 /* Clear mark bits from symbol nodes associated with a symtree node. */
2315 clear_sym_mark (gfc_symtree
* st
)
2318 st
->n
.sym
->mark
= 0;
2322 /* Recursively traverse the symtree nodes. */
2325 traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2332 traverse_symtree (st
->left
, func
);
2333 traverse_symtree (st
->right
, func
);
2339 gfc_traverse_symtree (gfc_namespace
* ns
, void (*func
) (gfc_symtree
*))
2342 traverse_symtree (ns
->sym_root
, func
);
2346 /* Recursive namespace traversal function. */
2349 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2355 if (st
->n
.sym
->mark
== 0)
2356 (*func
) (st
->n
.sym
);
2357 st
->n
.sym
->mark
= 1;
2359 traverse_ns (st
->left
, func
);
2360 traverse_ns (st
->right
, func
);
2364 /* Call a given function for all symbols in the namespace. We take
2365 care that each gfc_symbol node is called exactly once. */
2368 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2371 gfc_traverse_symtree (ns
, clear_sym_mark
);
2373 traverse_ns (ns
->sym_root
, func
);
2377 /* Given a symbol, mark it as SAVEd if it is allowed. */
2380 save_symbol (gfc_symbol
* sym
)
2383 if (sym
->attr
.use_assoc
)
2386 if (sym
->attr
.common
)
2388 gfc_add_saved_common (&sym
->attr
, &sym
->declared_at
);
2392 if (sym
->attr
.in_common
2394 || sym
->attr
.flavor
!= FL_VARIABLE
)
2397 gfc_add_save (&sym
->attr
, &sym
->declared_at
);
2401 /* Mark those symbols which can be SAVEd as such. */
2404 gfc_save_all (gfc_namespace
* ns
)
2407 gfc_traverse_ns (ns
, save_symbol
);
2412 /* Make sure that no changes to symbols are pending. */
2415 gfc_symbol_state(void) {
2417 if (changed_syms
!= NULL
)
2418 gfc_internal_error("Symbol changes still pending!");