]>
git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/symbol.c
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
)
726 if (check_used (attr
, where
) || check_done (attr
, where
))
730 return check_conflict (attr
, where
);
735 gfc_add_in_common (symbol_attribute
* attr
, locus
* where
)
738 if (check_used (attr
, where
) || check_done (attr
, where
))
741 /* Duplicate attribute already checked for. */
743 if (check_conflict (attr
, where
) == FAILURE
)
746 if (attr
->flavor
== FL_VARIABLE
)
749 return gfc_add_flavor (attr
, FL_VARIABLE
, where
);
754 gfc_add_in_namelist (symbol_attribute
* attr
, locus
* where
)
757 attr
->in_namelist
= 1;
758 return check_conflict (attr
, where
);
763 gfc_add_sequence (symbol_attribute
* attr
, locus
* where
)
766 if (check_used (attr
, where
))
770 return check_conflict (attr
, where
);
775 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
778 if (check_used (attr
, where
) || check_done (attr
, where
))
782 return check_conflict (attr
, where
);
787 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
790 if (check_used (attr
, where
) || check_done (attr
, where
))
794 return check_conflict (attr
, where
);
799 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
802 if (check_used (attr
, where
) || check_done (attr
, where
))
806 return check_conflict (attr
, where
);
811 gfc_add_entry (symbol_attribute
* attr
, locus
* where
)
814 if (check_used (attr
, where
))
819 duplicate_attr ("ENTRY", where
);
824 return check_conflict (attr
, where
);
829 gfc_add_function (symbol_attribute
* attr
, locus
* where
)
832 if (attr
->flavor
!= FL_PROCEDURE
833 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
837 return check_conflict (attr
, where
);
842 gfc_add_subroutine (symbol_attribute
* attr
, locus
* where
)
845 if (attr
->flavor
!= FL_PROCEDURE
846 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
849 attr
->subroutine
= 1;
850 return check_conflict (attr
, where
);
855 gfc_add_generic (symbol_attribute
* attr
, locus
* where
)
858 if (attr
->flavor
!= FL_PROCEDURE
859 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
863 return check_conflict (attr
, where
);
867 /* Flavors are special because some flavors are not what fortran
868 considers attributes and can be reaffirmed multiple times. */
871 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, locus
* where
)
874 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
875 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
876 || f
== FL_NAMELIST
) && check_used (attr
, where
))
879 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
882 if (attr
->flavor
!= FL_UNKNOWN
)
885 where
= gfc_current_locus ();
887 gfc_error ("%s attribute conflicts with %s attribute at %L",
888 gfc_code2string (flavors
, attr
->flavor
),
889 gfc_code2string (flavors
, f
), where
);
896 return check_conflict (attr
, where
);
901 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
, locus
* where
)
904 if (check_used (attr
, where
) || check_done (attr
, where
))
907 if (attr
->flavor
!= FL_PROCEDURE
908 && gfc_add_flavor (attr
, FL_PROCEDURE
, where
) == FAILURE
)
912 where
= gfc_current_locus ();
914 if (attr
->proc
!= PROC_UNKNOWN
)
916 gfc_error ("%s procedure at %L is already %s %s procedure",
917 gfc_code2string (procedures
, t
), where
,
918 gfc_article (gfc_code2string (procedures
, attr
->proc
)),
919 gfc_code2string (procedures
, attr
->proc
));
926 /* Statement functions are always scalar and functions. */
927 if (t
== PROC_ST_FUNCTION
928 && ((!attr
->function
&& gfc_add_function (attr
, where
) == FAILURE
)
932 return check_conflict (attr
, where
);
937 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
940 if (check_used (attr
, where
))
943 if (attr
->intent
== INTENT_UNKNOWN
)
945 attr
->intent
= intent
;
946 return check_conflict (attr
, where
);
950 where
= gfc_current_locus ();
952 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
953 gfc_intent_string (attr
->intent
),
954 gfc_intent_string (intent
), where
);
960 /* No checks for use-association in public and private statements. */
963 gfc_add_access (symbol_attribute
* attr
, gfc_access access
, locus
* where
)
966 if (attr
->access
== ACCESS_UNKNOWN
)
968 attr
->access
= access
;
969 return check_conflict (attr
, where
);
973 where
= gfc_current_locus ();
974 gfc_error ("ACCESS specification at %L was already specified", where
);
981 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
982 gfc_formal_arglist
* formal
, locus
* where
)
985 if (check_used (&sym
->attr
, where
))
989 where
= gfc_current_locus ();
991 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
992 && sym
->attr
.if_source
!= IFSRC_DECL
)
994 gfc_error ("Symbol '%s' at %L already has an explicit interface",
999 sym
->formal
= formal
;
1000 sym
->attr
.if_source
= source
;
1006 /* Add a type to a symbol. */
1009 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1013 /* TODO: This is legal if it is reaffirming an implicit type.
1014 if (check_done (&sym->attr, where))
1018 where
= gfc_current_locus ();
1020 if (sym
->ts
.type
!= BT_UNKNOWN
)
1022 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1023 where
, gfc_basic_typename (sym
->ts
.type
));
1027 flavor
= sym
->attr
.flavor
;
1029 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1030 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1031 && sym
->attr
.subroutine
)
1032 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1034 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1043 /* Clears all attributes. */
1046 gfc_clear_attr (symbol_attribute
* attr
)
1049 attr
->allocatable
= 0;
1050 attr
->dimension
= 0;
1052 attr
->intrinsic
= 0;
1062 attr
->use_assoc
= 0;
1063 attr
->in_namelist
= 0;
1065 attr
->in_common
= 0;
1066 attr
->saved_common
= 0;
1068 attr
->subroutine
= 0;
1070 attr
->implicit_type
= 0;
1072 attr
->elemental
= 0;
1074 attr
->recursive
= 0;
1076 attr
->access
= ACCESS_UNKNOWN
;
1077 attr
->intent
= INTENT_UNKNOWN
;
1078 attr
->flavor
= FL_UNKNOWN
;
1079 attr
->proc
= PROC_UNKNOWN
;
1080 attr
->if_source
= IFSRC_UNKNOWN
;
1084 /* Check for missing attributes in the new symbol. Currently does
1085 nothing, but it's not clear that it is unnecessary yet. */
1088 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1089 locus
* where ATTRIBUTE_UNUSED
)
1096 /* Copy an attribute to a symbol attribute, bit by bit. Some
1097 attributes have a lot of side-effects but cannot be present given
1098 where we are called from, so we ignore some bits. */
1101 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1104 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1107 if (src
->dimension
&& gfc_add_dimension (dest
, where
) == FAILURE
)
1109 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1111 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1113 if (src
->save
&& gfc_add_save (dest
, where
) == FAILURE
)
1115 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1117 if (src
->dummy
&& gfc_add_dummy (dest
, where
) == FAILURE
)
1119 if (src
->common
&& gfc_add_common (dest
, where
) == FAILURE
)
1121 if (src
->result
&& gfc_add_result (dest
, where
) == FAILURE
)
1126 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, where
) == FAILURE
)
1129 if (src
->in_common
&& gfc_add_in_common (dest
, where
) == FAILURE
)
1131 if (src
->saved_common
&& gfc_add_saved_common (dest
, where
) == FAILURE
)
1134 if (src
->generic
&& gfc_add_generic (dest
, where
) == FAILURE
)
1136 if (src
->function
&& gfc_add_function (dest
, where
) == FAILURE
)
1138 if (src
->subroutine
&& gfc_add_subroutine (dest
, where
) == FAILURE
)
1141 if (src
->sequence
&& gfc_add_sequence (dest
, where
) == FAILURE
)
1143 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1145 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1147 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1150 if (src
->flavor
!= FL_UNKNOWN
1151 && gfc_add_flavor (dest
, src
->flavor
, where
) == FAILURE
)
1154 if (src
->intent
!= INTENT_UNKNOWN
1155 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1158 if (src
->access
!= ACCESS_UNKNOWN
1159 && gfc_add_access (dest
, src
->access
, where
) == FAILURE
)
1162 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1165 /* The subroutines that set these bits also cause flavors to be set,
1166 and that has already happened in the original, so don't let to
1171 dest
->intrinsic
= 1;
1180 /************** Component name management ************/
1182 /* Component names of a derived type form their own little namespaces
1183 that are separate from all other spaces. The space is composed of
1184 a singly linked list of gfc_component structures whose head is
1185 located in the parent symbol. */
1188 /* Add a component name to a symbol. The call fails if the name is
1189 already present. On success, the component pointer is modified to
1190 point to the additional component structure. */
1193 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1195 gfc_component
*p
, *tail
;
1199 for (p
= sym
->components
; p
; p
= p
->next
)
1201 if (strcmp (p
->name
, name
) == 0)
1203 gfc_error ("Component '%s' at %C already declared at %L",
1211 /* Allocate new component */
1212 p
= gfc_get_component ();
1215 sym
->components
= p
;
1219 strcpy (p
->name
, name
);
1220 p
->loc
= *gfc_current_locus ();
1227 /* Recursive function to switch derived types of all symbol in a
1231 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1239 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1240 sym
->ts
.derived
= to
;
1242 switch_types (st
->left
, from
, to
);
1243 switch_types (st
->right
, from
, to
);
1247 /* This subroutine is called when a derived type is used in order to
1248 make the final determination about which version to use. The
1249 standard requires that a type be defined before it is 'used', but
1250 such types can appear in IMPLICIT statements before the actual
1251 definition. 'Using' in this context means declaring a variable to
1252 be that type or using the type constructor.
1254 If a type is used and the components haven't been defined, then we
1255 have to have a derived type in a parent unit. We find the node in
1256 the other namespace and point the symtree node in this namespace to
1257 that node. Further reference to this name point to the correct
1258 node. If we can't find the node in a parent namespace, then have
1261 This subroutine takes a pointer to a symbol node and returns a
1262 pointer to the translated node or NULL for an error. Usually there
1263 is no translation and we return the node we were passed. */
1265 static gfc_symtree
*
1266 gfc_use_ha_derived (gfc_symbol
* sym
)
1273 if (sym
->ns
->parent
== NULL
)
1276 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1278 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1282 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1285 /* Get rid of symbol sym, translating all references to s. */
1286 for (i
= 0; i
< GFC_LETTERS
; i
++)
1288 t
= &sym
->ns
->default_type
[i
];
1289 if (t
->derived
== sym
)
1293 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1298 /* Unlink from list of modified symbols. */
1299 if (changed_syms
== sym
)
1300 changed_syms
= sym
->tlink
;
1302 for (p
= changed_syms
; p
; p
= p
->tlink
)
1303 if (p
->tlink
== sym
)
1305 p
->tlink
= sym
->tlink
;
1309 switch_types (sym
->ns
->sym_root
, sym
, s
);
1311 /* TODO: Also have to replace sym -> s in other lists like
1312 namelists, common lists and interface lists. */
1313 gfc_free_symbol (sym
);
1318 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1325 gfc_use_derived (gfc_symbol
* sym
)
1329 if (sym
->components
!= NULL
)
1330 return sym
; /* Already defined */
1332 st
= gfc_use_ha_derived (sym
);
1340 /* Given a derived type node and a component name, try to locate the
1341 component structure. Returns the NULL pointer if the component is
1342 not found or the components are private. */
1345 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1352 sym
= gfc_use_derived (sym
);
1357 for (p
= sym
->components
; p
; p
= p
->next
)
1358 if (strcmp (p
->name
, name
) == 0)
1362 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1366 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1368 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1378 /* Given a symbol, free all of the component structures and everything
1382 free_components (gfc_component
* p
)
1390 gfc_free_array_spec (p
->as
);
1391 gfc_free_expr (p
->initializer
);
1398 /* Set component attributes from a standard symbol attribute
1402 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1405 c
->dimension
= attr
->dimension
;
1406 c
->pointer
= attr
->pointer
;
1410 /* Get a standard symbol attribute structure given the component
1414 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1417 gfc_clear_attr (attr
);
1418 attr
->dimension
= c
->dimension
;
1419 attr
->pointer
= c
->pointer
;
1423 /******************** Statement label management ********************/
1425 /* Free a single gfc_st_label structure, making sure the list is not
1426 messed up. This function is called only when some parse error
1430 gfc_free_st_label (gfc_st_label
* l
)
1437 (l
->prev
->next
= l
->next
);
1440 (l
->next
->prev
= l
->prev
);
1442 if (l
->format
!= NULL
)
1443 gfc_free_expr (l
->format
);
1447 /* Free a whole list of gfc_st_label structures. */
1450 free_st_labels (gfc_st_label
* l1
)
1457 if (l1
->format
!= NULL
)
1458 gfc_free_expr (l1
->format
);
1464 /* Given a label number, search for and return a pointer to the label
1465 structure, creating it if it does not exist. */
1468 gfc_get_st_label (int labelno
)
1472 /* First see if the label is already in this namespace. */
1473 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1474 if (lp
->value
== labelno
)
1479 lp
= gfc_getmem (sizeof (gfc_st_label
));
1481 lp
->value
= labelno
;
1482 lp
->defined
= ST_LABEL_UNKNOWN
;
1483 lp
->referenced
= ST_LABEL_UNKNOWN
;
1486 lp
->next
= gfc_current_ns
->st_labels
;
1487 if (gfc_current_ns
->st_labels
)
1488 gfc_current_ns
->st_labels
->prev
= lp
;
1489 gfc_current_ns
->st_labels
= lp
;
1495 /* Called when a statement with a statement label is about to be
1496 accepted. We add the label to the list of the current namespace,
1497 making sure it hasn't been defined previously and referenced
1501 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1505 labelno
= lp
->value
;
1507 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1508 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1509 &lp
->where
, label_locus
);
1512 lp
->where
= *label_locus
;
1516 case ST_LABEL_FORMAT
:
1517 if (lp
->referenced
== ST_LABEL_TARGET
)
1518 gfc_error ("Label %d at %C already referenced as branch target",
1521 lp
->defined
= ST_LABEL_FORMAT
;
1525 case ST_LABEL_TARGET
:
1526 if (lp
->referenced
== ST_LABEL_FORMAT
)
1527 gfc_error ("Label %d at %C already referenced as a format label",
1530 lp
->defined
= ST_LABEL_TARGET
;
1535 lp
->defined
= ST_LABEL_BAD_TARGET
;
1536 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1542 /* Reference a label. Given a label and its type, see if that
1543 reference is consistent with what is known about that label,
1544 updating the unknown state. Returns FAILURE if something goes
1548 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1550 gfc_sl_type label_type
;
1557 labelno
= lp
->value
;
1559 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1560 label_type
= lp
->defined
;
1563 label_type
= lp
->referenced
;
1564 lp
->where
= *gfc_current_locus ();
1567 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1569 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1574 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1575 && type
== ST_LABEL_FORMAT
)
1577 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1582 lp
->referenced
= type
;
1590 /************** Symbol table management subroutines ****************/
1592 /* Basic details: Fortran 95 requires a potentially unlimited number
1593 of distinct namespaces when compiling a program unit. This case
1594 occurs during a compilation of internal subprograms because all of
1595 the internal subprograms must be read before we can start
1596 generating code for the host.
1598 Given the tricky nature of the fortran grammar, we must be able to
1599 undo changes made to a symbol table if the current interpretation
1600 of a statement is found to be incorrect. Whenever a symbol is
1601 looked up, we make a copy of it and link to it. All of these
1602 symbols are kept in a singly linked list so that we can commit or
1603 undo the changes at a later time.
1605 A symtree may point to a symbol node outside of it's namespace. In
1606 this case, that symbol has been used as a host associated variable
1607 at some previous time. */
1609 /* Allocate a new namespace structure. */
1612 gfc_get_namespace (gfc_namespace
* parent
)
1616 gfc_intrinsic_op in
;
1619 ns
= gfc_getmem (sizeof (gfc_namespace
));
1620 ns
->sym_root
= NULL
;
1621 ns
->uop_root
= NULL
;
1622 ns
->default_access
= ACCESS_UNKNOWN
;
1623 ns
->parent
= parent
;
1625 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1626 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1628 /* Initialize default implicit types. */
1629 for (i
= 'a'; i
<= 'z'; i
++)
1631 ns
->set_flag
[i
- 'a'] = 0;
1632 ts
= &ns
->default_type
[i
- 'a'];
1634 if (ns
->parent
!= NULL
)
1636 /* Copy parent settings */
1637 *ts
= ns
->parent
->default_type
[i
- 'a'];
1641 if (gfc_option
.flag_implicit_none
!= 0)
1647 if ('i' <= i
&& i
<= 'n')
1649 ts
->type
= BT_INTEGER
;
1650 ts
->kind
= gfc_default_integer_kind ();
1655 ts
->kind
= gfc_default_real_kind ();
1663 /* Comparison function for symtree nodes. */
1666 compare_symtree (void * _st1
, void * _st2
)
1668 gfc_symtree
*st1
, *st2
;
1670 st1
= (gfc_symtree
*) _st1
;
1671 st2
= (gfc_symtree
*) _st2
;
1673 return strcmp (st1
->name
, st2
->name
);
1677 /* Allocate a new symtree node and associate it with the new symbol. */
1680 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1684 st
= gfc_getmem (sizeof (gfc_symtree
));
1685 strcpy (st
->name
, name
);
1687 gfc_insert_bbt (root
, st
, compare_symtree
);
1692 /* Delete a symbol from the tree. Does not free the symbol itself! */
1695 delete_symtree (gfc_symtree
** root
, const char *name
)
1697 gfc_symtree st
, *st0
;
1699 st0
= gfc_find_symtree (*root
, name
);
1701 strcpy (st
.name
, name
);
1702 gfc_delete_bbt (root
, &st
, compare_symtree
);
1708 /* Given a root symtree node and a name, try to find the symbol within
1709 the namespace. Returns NULL if the symbol is not found. */
1712 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1718 c
= strcmp (name
, st
->name
);
1722 st
= (c
< 0) ? st
->left
: st
->right
;
1729 /* Given a name find a user operator node, creating it if it doesn't
1730 exist. These are much simpler than symbols because they can't be
1731 ambiguous with one another. */
1734 gfc_get_uop (const char *name
)
1739 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1743 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1745 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1746 strcpy (uop
->name
, name
);
1747 uop
->access
= ACCESS_UNKNOWN
;
1748 uop
->ns
= gfc_current_ns
;
1754 /* Given a name find the user operator node. Returns NULL if it does
1758 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1763 ns
= gfc_current_ns
;
1765 st
= gfc_find_symtree (ns
->uop_root
, name
);
1766 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1770 /* Remove a gfc_symbol structure and everything it points to. */
1773 gfc_free_symbol (gfc_symbol
* sym
)
1779 gfc_free_array_spec (sym
->as
);
1781 free_components (sym
->components
);
1783 gfc_free_expr (sym
->value
);
1785 gfc_free_namelist (sym
->namelist
);
1787 gfc_free_namespace (sym
->formal_ns
);
1789 gfc_free_interface (sym
->generic
);
1791 gfc_free_formal_arglist (sym
->formal
);
1797 /* Allocate and initialize a new symbol node. */
1800 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1804 p
= gfc_getmem (sizeof (gfc_symbol
));
1806 gfc_clear_ts (&p
->ts
);
1807 gfc_clear_attr (&p
->attr
);
1810 p
->declared_at
= *gfc_current_locus ();
1812 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1813 gfc_internal_error ("new_symbol(): Symbol name too long");
1815 strcpy (p
->name
, name
);
1820 /* Generate an error if a symbol is ambiguous. */
1823 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1826 if (st
->n
.sym
->module
[0])
1827 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1828 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1830 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1831 "from current program unit", name
, st
->n
.sym
->name
);
1835 /* Search for a symbol starting in the current namespace, resorting to
1836 any parent namespaces if requested by a nonzero parent_flag.
1837 Returns nonzero if the symbol is ambiguous. */
1840 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1841 gfc_symtree
** result
)
1846 ns
= gfc_current_ns
;
1850 st
= gfc_find_symtree (ns
->sym_root
, name
);
1856 ambiguous_symbol (name
, st
);
1876 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1877 gfc_symbol
** result
)
1882 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1887 *result
= st
->n
.sym
;
1893 /* Save symbol with the information necessary to back it out. */
1896 save_symbol_data (gfc_symbol
* sym
)
1899 if (sym
->new || sym
->old_symbol
!= NULL
)
1902 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1903 *(sym
->old_symbol
) = *sym
;
1905 sym
->tlink
= changed_syms
;
1910 /* Given a name, find a symbol, or create it if it does not exist yet
1911 in the current namespace. If the symbol is found we make sure that
1914 The integer return code indicates
1916 1 The symbol name was ambiguous
1917 2 The name meant to be established was already host associated.
1919 So if the return value is nonzero, then an error was issued. */
1922 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1927 /* This doesn't usually happen during resolution. */
1929 ns
= gfc_current_ns
;
1931 /* Try to find the symbol in ns. */
1932 st
= gfc_find_symtree (ns
->sym_root
, name
);
1936 /* If not there, create a new symbol. */
1937 p
= gfc_new_symbol (name
, ns
);
1939 /* Add to the list of tentative symbols. */
1940 p
->old_symbol
= NULL
;
1941 p
->tlink
= changed_syms
;
1946 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1953 /* Make sure the existing symbol is OK. */
1956 ambiguous_symbol (name
, st
);
1962 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1964 /* Symbol is from another namespace. */
1965 gfc_error ("Symbol '%s' at %C has already been host associated",
1972 /* Copy in case this symbol is changed. */
1973 save_symbol_data (p
);
1982 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1988 i
= gfc_get_sym_tree (name
, ns
, &st
);
1993 *result
= st
->n
.sym
;
2000 /* Subroutine that searches for a symbol, creating it if it doesn't
2001 exist, but tries to host-associate the symbol if possible. */
2004 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2009 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2012 save_symbol_data (st
->n
.sym
);
2018 if (gfc_current_ns
->parent
!= NULL
)
2020 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2031 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2036 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2041 i
= gfc_get_ha_sym_tree (name
, &st
);
2044 *result
= st
->n
.sym
;
2051 /* Return true if both symbols could refer to the same data object. Does
2052 not take account of aliasing due to equivalence statements. */
2055 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2057 /* Aliasing isn't possible if the symbols have different base types. */
2058 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2061 /* Pointers can point to other pointers, target objects and allocatable
2062 objects. Two allocatable objects cannot share the same storage. */
2063 if (lsym
->attr
.pointer
2064 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2066 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2068 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2075 /* Undoes all the changes made to symbols in the current statement.
2076 This subroutine is made simpler due to the fact that attributes are
2077 never removed once added. */
2080 gfc_undo_symbols (void)
2082 gfc_symbol
*p
, *q
, *old
;
2084 for (p
= changed_syms
; p
; p
= q
)
2090 /* Symbol was new. */
2091 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2095 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2097 gfc_free_symbol (p
);
2101 /* Restore previous state of symbol. Just copy simple stuff. */
2103 old
= p
->old_symbol
;
2105 p
->ts
.type
= old
->ts
.type
;
2106 p
->ts
.kind
= old
->ts
.kind
;
2108 p
->attr
= old
->attr
;
2110 if (p
->value
!= old
->value
)
2112 gfc_free_expr (old
->value
);
2116 if (p
->as
!= old
->as
)
2119 gfc_free_array_spec (p
->as
);
2123 p
->generic
= old
->generic
;
2124 p
->component_access
= old
->component_access
;
2126 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2128 gfc_free_namelist (p
->namelist
);
2134 if (p
->namelist_tail
!= old
->namelist_tail
)
2136 gfc_free_namelist (old
->namelist_tail
);
2137 old
->namelist_tail
->next
= NULL
;
2141 p
->namelist_tail
= old
->namelist_tail
;
2143 if (p
->formal
!= old
->formal
)
2145 gfc_free_formal_arglist (p
->formal
);
2146 p
->formal
= old
->formal
;
2149 gfc_free (p
->old_symbol
);
2150 p
->old_symbol
= NULL
;
2154 changed_syms
= NULL
;
2158 /* Makes the changes made in the current statement permanent-- gets
2159 rid of undo information. */
2162 gfc_commit_symbols (void)
2166 for (p
= changed_syms
; p
; p
= q
)
2173 if (p
->old_symbol
!= NULL
)
2175 gfc_free (p
->old_symbol
);
2176 p
->old_symbol
= NULL
;
2180 changed_syms
= NULL
;
2184 /* Recursive function that deletes an entire tree and all the user
2185 operator nodes that it contains. */
2188 free_uop_tree (gfc_symtree
* uop_tree
)
2191 if (uop_tree
== NULL
)
2194 free_uop_tree (uop_tree
->left
);
2195 free_uop_tree (uop_tree
->right
);
2197 gfc_free_interface (uop_tree
->n
.uop
->operator);
2199 gfc_free (uop_tree
->n
.uop
);
2200 gfc_free (uop_tree
);
2204 /* Recursive function that deletes an entire tree and all the symbols
2205 that it contains. */
2208 free_sym_tree (gfc_symtree
* sym_tree
)
2213 if (sym_tree
== NULL
)
2216 free_sym_tree (sym_tree
->left
);
2217 free_sym_tree (sym_tree
->right
);
2219 sym
= sym_tree
->n
.sym
;
2223 gfc_internal_error ("free_sym_tree(): Negative refs");
2225 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2227 /* As formal_ns contains a reference to sym, delete formal_ns just
2228 before the deletion of sym. */
2229 ns
= sym
->formal_ns
;
2230 sym
->formal_ns
= NULL
;
2231 gfc_free_namespace (ns
);
2233 else if (sym
->refs
== 0)
2235 /* Go ahead and delete the symbol. */
2236 gfc_free_symbol (sym
);
2239 gfc_free (sym_tree
);
2243 /* Free a namespace structure and everything below it. Interface
2244 lists associated with intrinsic operators are not freed. These are
2245 taken care of when a specific name is freed. */
2248 gfc_free_namespace (gfc_namespace
* ns
)
2250 gfc_charlen
*cl
, *cl2
;
2251 gfc_namespace
*p
, *q
;
2257 gfc_free_statements (ns
->code
);
2259 free_sym_tree (ns
->sym_root
);
2260 free_uop_tree (ns
->uop_root
);
2262 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2265 gfc_free_expr (cl
->length
);
2269 free_st_labels (ns
->st_labels
);
2271 gfc_free_equiv (ns
->equiv
);
2273 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2274 gfc_free_interface (ns
->operator[i
]);
2276 gfc_free_data (ns
->data
);
2280 /* Recursively free any contained namespaces. */
2286 gfc_free_namespace (q
);
2292 gfc_symbol_init_2 (void)
2295 gfc_current_ns
= gfc_get_namespace (NULL
);
2300 gfc_symbol_done_2 (void)
2303 gfc_free_namespace (gfc_current_ns
);
2304 gfc_current_ns
= NULL
;
2308 /* Clear mark bits from symbol nodes associated with a symtree node. */
2311 clear_sym_mark (gfc_symtree
* st
)
2314 st
->n
.sym
->mark
= 0;
2318 /* Recursively traverse the symtree nodes. */
2321 traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2328 traverse_symtree (st
->left
, func
);
2329 traverse_symtree (st
->right
, func
);
2335 gfc_traverse_symtree (gfc_namespace
* ns
, void (*func
) (gfc_symtree
*))
2338 traverse_symtree (ns
->sym_root
, func
);
2342 /* Recursive namespace traversal function. */
2345 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2351 if (st
->n
.sym
->mark
== 0)
2352 (*func
) (st
->n
.sym
);
2353 st
->n
.sym
->mark
= 1;
2355 traverse_ns (st
->left
, func
);
2356 traverse_ns (st
->right
, func
);
2360 /* Call a given function for all symbols in the namespace. We take
2361 care that each gfc_symbol node is called exactly once. */
2364 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2367 gfc_traverse_symtree (ns
, clear_sym_mark
);
2369 traverse_ns (ns
->sym_root
, func
);
2373 /* Given a symbol, mark it as SAVEd if it is allowed. */
2376 save_symbol (gfc_symbol
* sym
)
2379 if (sym
->attr
.use_assoc
)
2382 if (sym
->attr
.common
)
2384 gfc_add_saved_common (&sym
->attr
, &sym
->declared_at
);
2388 if (sym
->attr
.in_common
2390 || sym
->attr
.flavor
!= FL_VARIABLE
)
2393 gfc_add_save (&sym
->attr
, &sym
->declared_at
);
2397 /* Mark those symbols which can be SAVEd as such. */
2400 gfc_save_all (gfc_namespace
* ns
)
2403 gfc_traverse_ns (ns
, save_symbol
);
2408 /* Make sure that no changes to symbols are pending. */
2411 gfc_symbol_state(void) {
2413 if (changed_syms
!= NULL
)
2414 gfc_internal_error("Symbol changes still pending!");