1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors
[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
37 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
38 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
39 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 const mstring procedures
[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
46 minit ("MODULE-PROC", PROC_MODULE
),
47 minit ("INTERNAL-PROC", PROC_INTERNAL
),
48 minit ("DUMMY-PROC", PROC_DUMMY
),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
55 const mstring intents
[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
58 minit ("IN", INTENT_IN
),
59 minit ("OUT", INTENT_OUT
),
60 minit ("INOUT", INTENT_INOUT
),
64 const mstring access_types
[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
67 minit ("PUBLIC", ACCESS_PUBLIC
),
68 minit ("PRIVATE", ACCESS_PRIVATE
),
72 const mstring ifsrc_types
[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN
),
75 minit ("DECL", IFSRC_DECL
),
76 minit ("BODY", IFSRC_IFBODY
),
77 minit ("USAGE", IFSRC_USAGE
)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order
= 1;
87 gfc_namespace
*gfc_current_ns
;
89 gfc_gsymbol
*gfc_gsym_root
= NULL
;
91 static gfc_symbol
*changed_syms
= NULL
;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag
[GFC_LETTERS
];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 if (gfc_current_ns
->seen_implicit_none
)
111 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
115 gfc_current_ns
->seen_implicit_none
= 1;
117 for (i
= 0; i
< GFC_LETTERS
; i
++)
119 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
120 gfc_current_ns
->set_flag
[i
] = 1;
125 /* Reset the implicit range flags. */
128 gfc_clear_new_implicit (void)
132 for (i
= 0; i
< GFC_LETTERS
; i
++)
137 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
140 gfc_add_new_implicit_range (int c1
, int c2
)
147 for (i
= c1
; i
<= c2
; i
++)
151 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
163 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
164 the new implicit types back into the existing types will work. */
167 gfc_merge_new_implicit (gfc_typespec
* ts
)
171 if (gfc_current_ns
->seen_implicit_none
)
173 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
177 for (i
= 0; i
< GFC_LETTERS
; i
++)
182 if (gfc_current_ns
->set_flag
[i
])
184 gfc_error ("Letter %c already has an IMPLICIT type at %C",
188 gfc_current_ns
->default_type
[i
] = *ts
;
189 gfc_current_ns
->set_flag
[i
] = 1;
196 /* Given a symbol, return a pointer to the typespec for its default type. */
199 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
203 letter
= sym
->name
[0];
204 if (letter
< 'a' || letter
> 'z')
205 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
210 return &ns
->default_type
[letter
- 'a'];
214 /* Given a pointer to a symbol, set its type according to the first
215 letter of its name. Fails if the letter in question has no default
219 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
223 if (sym
->ts
.type
!= BT_UNKNOWN
)
224 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
226 ts
= gfc_get_default_type (sym
, ns
);
228 if (ts
->type
== BT_UNKNOWN
)
230 if (error_flag
&& !sym
->attr
.untyped
)
232 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
233 sym
->name
, &sym
->declared_at
);
234 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
241 sym
->attr
.implicit_type
= 1;
247 /******************** Symbol attribute stuff *********************/
249 /* This is a generic conflict-checker. We do this to avoid having a
250 single conflict in two places. */
252 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
253 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
256 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
258 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
259 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
260 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
261 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
262 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
263 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
264 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
265 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
266 *use_assoc
= "USE ASSOCIATED";
271 where
= &gfc_current_locus
;
273 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
280 /* Check for attributes not allowed in a BLOCK DATA. */
281 if (gfc_current_state () == COMP_BLOCK_DATA
)
285 if (attr
->allocatable
)
291 if (attr
->access
== ACCESS_PRIVATE
)
293 if (attr
->access
== ACCESS_PUBLIC
)
295 if (attr
->intent
!= INTENT_UNKNOWN
)
301 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
308 conf (pointer
, target
);
309 conf (pointer
, external
);
310 conf (pointer
, intrinsic
);
311 conf (target
, external
);
312 conf (target
, intrinsic
);
313 conf (external
, dimension
); /* See Fortran 95's R504. */
315 conf (external
, intrinsic
);
316 conf (allocatable
, pointer
);
317 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
318 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
319 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
320 conf (elemental
, recursive
);
322 conf (in_common
, dummy
);
323 conf (in_common
, allocatable
);
324 conf (in_common
, result
);
325 conf (in_common
, save
);
328 conf (dummy
, result
);
330 conf (in_equivalence
, use_assoc
);
331 conf (in_equivalence
, dummy
);
332 conf (in_equivalence
, target
);
333 conf (in_equivalence
, pointer
);
334 conf (in_equivalence
, function
);
335 conf (in_equivalence
, result
);
336 conf (in_equivalence
, entry
);
337 conf (in_equivalence
, allocatable
);
339 conf (in_namelist
, pointer
);
340 conf (in_namelist
, allocatable
);
342 conf (entry
, result
);
344 conf (function
, subroutine
);
346 a1
= gfc_code2string (flavors
, attr
->flavor
);
348 if (attr
->in_namelist
349 && attr
->flavor
!= FL_VARIABLE
350 && attr
->flavor
!= FL_UNKNOWN
)
357 switch (attr
->flavor
)
384 if (attr
->subroutine
)
397 case PROC_ST_FUNCTION
:
431 if (attr
->intent
!= INTENT_UNKNOWN
)
461 gfc_error ("%s attribute conflicts with %s attribute at %L",
464 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
465 a1
, a2
, name
, where
);
474 /* Mark a symbol as referenced. */
477 gfc_set_sym_referenced (gfc_symbol
* sym
)
479 if (sym
->attr
.referenced
)
482 sym
->attr
.referenced
= 1;
484 /* Remember which order dummy variables are accessed in. */
486 sym
->dummy_order
= next_dummy_order
++;
490 /* Common subroutine called by attribute changing subroutines in order
491 to prevent them from changing a symbol that has been
492 use-associated. Returns zero if it is OK to change the symbol,
496 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
499 if (attr
->use_assoc
== 0)
503 where
= &gfc_current_locus
;
506 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
509 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
516 /* Used to prevent changing the attributes of a symbol after it has been
517 used. This check is only done for dummy variables as only these can be
518 used in specification expressions. Applying this to all symbols causes
519 an error when we reach the body of a contained function. */
522 check_done (symbol_attribute
* attr
, locus
* where
)
525 if (!(attr
->dummy
&& attr
->referenced
))
529 where
= &gfc_current_locus
;
531 gfc_error ("Cannot change attributes of symbol at %L"
532 " after it has been used", where
);
538 /* Generate an error because of a duplicate attribute. */
541 duplicate_attr (const char *attr
, locus
* where
)
545 where
= &gfc_current_locus
;
547 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
552 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
555 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
558 if (attr
->allocatable
)
560 duplicate_attr ("ALLOCATABLE", where
);
564 attr
->allocatable
= 1;
565 return check_conflict (attr
, NULL
, where
);
570 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
573 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
578 duplicate_attr ("DIMENSION", where
);
583 return check_conflict (attr
, name
, where
);
588 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
591 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
596 duplicate_attr ("EXTERNAL", where
);
602 return check_conflict (attr
, NULL
, where
);
607 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
610 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
615 duplicate_attr ("INTRINSIC", where
);
621 return check_conflict (attr
, NULL
, where
);
626 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
629 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
634 duplicate_attr ("OPTIONAL", where
);
639 return check_conflict (attr
, NULL
, where
);
644 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
647 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
651 return check_conflict (attr
, NULL
, where
);
656 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
659 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
663 return check_conflict (attr
, name
, where
);
668 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
671 if (check_used (attr
, name
, where
))
677 ("SAVE attribute at %L cannot be specified in a PURE procedure",
684 if (gfc_notify_std (GFC_STD_LEGACY
,
685 "Duplicate SAVE attribute specified at %L",
692 return check_conflict (attr
, name
, where
);
697 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
700 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
705 duplicate_attr ("TARGET", where
);
710 return check_conflict (attr
, NULL
, where
);
715 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
718 if (check_used (attr
, name
, where
))
721 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
723 return check_conflict (attr
, name
, where
);
728 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
731 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
734 /* Duplicate attribute already checked for. */
736 if (check_conflict (attr
, name
, where
) == FAILURE
)
739 if (attr
->flavor
== FL_VARIABLE
)
742 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
746 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
749 /* Duplicate attribute already checked for. */
750 attr
->in_equivalence
= 1;
751 if (check_conflict (attr
, name
, where
) == FAILURE
)
754 if (attr
->flavor
== FL_VARIABLE
)
757 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
762 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
765 if (check_used (attr
, name
, where
))
769 return check_conflict (attr
, name
, where
);
774 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
778 attr
->in_namelist
= 1;
779 return check_conflict (attr
, name
, where
);
784 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
787 if (check_used (attr
, name
, where
))
791 return check_conflict (attr
, name
, where
);
796 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
799 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
803 return check_conflict (attr
, NULL
, where
);
808 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
811 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
815 return check_conflict (attr
, NULL
, where
);
820 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
823 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
827 return check_conflict (attr
, NULL
, where
);
832 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
835 if (check_used (attr
, name
, where
))
840 duplicate_attr ("ENTRY", where
);
845 return check_conflict (attr
, name
, where
);
850 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
853 if (attr
->flavor
!= FL_PROCEDURE
854 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
858 return check_conflict (attr
, name
, where
);
863 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
866 if (attr
->flavor
!= FL_PROCEDURE
867 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
870 attr
->subroutine
= 1;
871 return check_conflict (attr
, name
, where
);
876 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
879 if (attr
->flavor
!= FL_PROCEDURE
880 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
884 return check_conflict (attr
, name
, where
);
888 /* Flavors are special because some flavors are not what Fortran
889 considers attributes and can be reaffirmed multiple times. */
892 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
896 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
897 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
898 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
901 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
904 if (attr
->flavor
!= FL_UNKNOWN
)
907 where
= &gfc_current_locus
;
909 gfc_error ("%s attribute conflicts with %s attribute at %L",
910 gfc_code2string (flavors
, attr
->flavor
),
911 gfc_code2string (flavors
, f
), where
);
918 return check_conflict (attr
, name
, where
);
923 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
924 const char *name
, locus
* where
)
927 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
930 if (attr
->flavor
!= FL_PROCEDURE
931 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
935 where
= &gfc_current_locus
;
937 if (attr
->proc
!= PROC_UNKNOWN
)
939 gfc_error ("%s procedure at %L is already declared as %s procedure",
940 gfc_code2string (procedures
, t
), where
,
941 gfc_code2string (procedures
, attr
->proc
));
948 /* Statement functions are always scalar and functions. */
949 if (t
== PROC_ST_FUNCTION
950 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
954 return check_conflict (attr
, name
, where
);
959 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
962 if (check_used (attr
, NULL
, where
))
965 if (attr
->intent
== INTENT_UNKNOWN
)
967 attr
->intent
= intent
;
968 return check_conflict (attr
, NULL
, where
);
972 where
= &gfc_current_locus
;
974 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
975 gfc_intent_string (attr
->intent
),
976 gfc_intent_string (intent
), where
);
982 /* No checks for use-association in public and private statements. */
985 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
986 const char *name
, locus
* where
)
989 if (attr
->access
== ACCESS_UNKNOWN
)
991 attr
->access
= access
;
992 return check_conflict (attr
, name
, where
);
996 where
= &gfc_current_locus
;
997 gfc_error ("ACCESS specification at %L was already specified", where
);
1004 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1005 gfc_formal_arglist
* formal
, locus
* where
)
1008 if (check_used (&sym
->attr
, sym
->name
, where
))
1012 where
= &gfc_current_locus
;
1014 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1015 && sym
->attr
.if_source
!= IFSRC_DECL
)
1017 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1022 sym
->formal
= formal
;
1023 sym
->attr
.if_source
= source
;
1029 /* Add a type to a symbol. */
1032 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1036 /* TODO: This is legal if it is reaffirming an implicit type.
1037 if (check_done (&sym->attr, where))
1041 where
= &gfc_current_locus
;
1043 if (sym
->ts
.type
!= BT_UNKNOWN
)
1045 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1046 where
, gfc_basic_typename (sym
->ts
.type
));
1050 flavor
= sym
->attr
.flavor
;
1052 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1053 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1054 && sym
->attr
.subroutine
)
1055 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1057 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1066 /* Clears all attributes. */
1069 gfc_clear_attr (symbol_attribute
* attr
)
1071 memset (attr
, 0, sizeof(symbol_attribute
));
1075 /* Check for missing attributes in the new symbol. Currently does
1076 nothing, but it's not clear that it is unnecessary yet. */
1079 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1080 locus
* where ATTRIBUTE_UNUSED
)
1087 /* Copy an attribute to a symbol attribute, bit by bit. Some
1088 attributes have a lot of side-effects but cannot be present given
1089 where we are called from, so we ignore some bits. */
1092 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1095 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1098 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1100 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1102 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1104 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1106 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1108 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1110 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1115 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1118 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1121 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1123 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1125 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1128 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1130 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1132 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1134 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1137 if (src
->flavor
!= FL_UNKNOWN
1138 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1141 if (src
->intent
!= INTENT_UNKNOWN
1142 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1145 if (src
->access
!= ACCESS_UNKNOWN
1146 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1149 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1152 /* The subroutines that set these bits also cause flavors to be set,
1153 and that has already happened in the original, so don't let it
1158 dest
->intrinsic
= 1;
1167 /************** Component name management ************/
1169 /* Component names of a derived type form their own little namespaces
1170 that are separate from all other spaces. The space is composed of
1171 a singly linked list of gfc_component structures whose head is
1172 located in the parent symbol. */
1175 /* Add a component name to a symbol. The call fails if the name is
1176 already present. On success, the component pointer is modified to
1177 point to the additional component structure. */
1180 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1182 gfc_component
*p
, *tail
;
1186 for (p
= sym
->components
; p
; p
= p
->next
)
1188 if (strcmp (p
->name
, name
) == 0)
1190 gfc_error ("Component '%s' at %C already declared at %L",
1198 /* Allocate a new component. */
1199 p
= gfc_get_component ();
1202 sym
->components
= p
;
1206 p
->name
= gfc_get_string (name
);
1207 p
->loc
= gfc_current_locus
;
1214 /* Recursive function to switch derived types of all symbol in a
1218 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1226 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1227 sym
->ts
.derived
= to
;
1229 switch_types (st
->left
, from
, to
);
1230 switch_types (st
->right
, from
, to
);
1234 /* This subroutine is called when a derived type is used in order to
1235 make the final determination about which version to use. The
1236 standard requires that a type be defined before it is 'used', but
1237 such types can appear in IMPLICIT statements before the actual
1238 definition. 'Using' in this context means declaring a variable to
1239 be that type or using the type constructor.
1241 If a type is used and the components haven't been defined, then we
1242 have to have a derived type in a parent unit. We find the node in
1243 the other namespace and point the symtree node in this namespace to
1244 that node. Further reference to this name point to the correct
1245 node. If we can't find the node in a parent namespace, then we have
1248 This subroutine takes a pointer to a symbol node and returns a
1249 pointer to the translated node or NULL for an error. Usually there
1250 is no translation and we return the node we were passed. */
1253 gfc_use_derived (gfc_symbol
* sym
)
1260 if (sym
->components
!= NULL
)
1261 return sym
; /* Already defined. */
1263 if (sym
->ns
->parent
== NULL
)
1266 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1268 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1272 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1275 /* Get rid of symbol sym, translating all references to s. */
1276 for (i
= 0; i
< GFC_LETTERS
; i
++)
1278 t
= &sym
->ns
->default_type
[i
];
1279 if (t
->derived
== sym
)
1283 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1288 /* Unlink from list of modified symbols. */
1289 if (changed_syms
== sym
)
1290 changed_syms
= sym
->tlink
;
1292 for (p
= changed_syms
; p
; p
= p
->tlink
)
1293 if (p
->tlink
== sym
)
1295 p
->tlink
= sym
->tlink
;
1299 switch_types (sym
->ns
->sym_root
, sym
, s
);
1301 /* TODO: Also have to replace sym -> s in other lists like
1302 namelists, common lists and interface lists. */
1303 gfc_free_symbol (sym
);
1308 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1314 /* Given a derived type node and a component name, try to locate the
1315 component structure. Returns the NULL pointer if the component is
1316 not found or the components are private. */
1319 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1326 sym
= gfc_use_derived (sym
);
1331 for (p
= sym
->components
; p
; p
= p
->next
)
1332 if (strcmp (p
->name
, name
) == 0)
1336 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1340 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1342 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1352 /* Given a symbol, free all of the component structures and everything
1356 free_components (gfc_component
* p
)
1364 gfc_free_array_spec (p
->as
);
1365 gfc_free_expr (p
->initializer
);
1372 /* Set component attributes from a standard symbol attribute
1376 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1379 c
->dimension
= attr
->dimension
;
1380 c
->pointer
= attr
->pointer
;
1384 /* Get a standard symbol attribute structure given the component
1388 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1391 gfc_clear_attr (attr
);
1392 attr
->dimension
= c
->dimension
;
1393 attr
->pointer
= c
->pointer
;
1397 /******************** Statement label management ********************/
1399 /* Free a single gfc_st_label structure, making sure the list is not
1400 messed up. This function is called only when some parse error
1404 gfc_free_st_label (gfc_st_label
* l
)
1411 (l
->prev
->next
= l
->next
);
1414 (l
->next
->prev
= l
->prev
);
1416 if (l
->format
!= NULL
)
1417 gfc_free_expr (l
->format
);
1421 /* Free a whole list of gfc_st_label structures. */
1424 free_st_labels (gfc_st_label
* l1
)
1431 if (l1
->format
!= NULL
)
1432 gfc_free_expr (l1
->format
);
1438 /* Given a label number, search for and return a pointer to the label
1439 structure, creating it if it does not exist. */
1442 gfc_get_st_label (int labelno
)
1446 /* First see if the label is already in this namespace. */
1447 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1448 if (lp
->value
== labelno
)
1453 lp
= gfc_getmem (sizeof (gfc_st_label
));
1455 lp
->value
= labelno
;
1456 lp
->defined
= ST_LABEL_UNKNOWN
;
1457 lp
->referenced
= ST_LABEL_UNKNOWN
;
1460 lp
->next
= gfc_current_ns
->st_labels
;
1461 if (gfc_current_ns
->st_labels
)
1462 gfc_current_ns
->st_labels
->prev
= lp
;
1463 gfc_current_ns
->st_labels
= lp
;
1469 /* Called when a statement with a statement label is about to be
1470 accepted. We add the label to the list of the current namespace,
1471 making sure it hasn't been defined previously and referenced
1475 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1479 labelno
= lp
->value
;
1481 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1482 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1483 &lp
->where
, label_locus
);
1486 lp
->where
= *label_locus
;
1490 case ST_LABEL_FORMAT
:
1491 if (lp
->referenced
== ST_LABEL_TARGET
)
1492 gfc_error ("Label %d at %C already referenced as branch target",
1495 lp
->defined
= ST_LABEL_FORMAT
;
1499 case ST_LABEL_TARGET
:
1500 if (lp
->referenced
== ST_LABEL_FORMAT
)
1501 gfc_error ("Label %d at %C already referenced as a format label",
1504 lp
->defined
= ST_LABEL_TARGET
;
1509 lp
->defined
= ST_LABEL_BAD_TARGET
;
1510 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1516 /* Reference a label. Given a label and its type, see if that
1517 reference is consistent with what is known about that label,
1518 updating the unknown state. Returns FAILURE if something goes
1522 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1524 gfc_sl_type label_type
;
1531 labelno
= lp
->value
;
1533 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1534 label_type
= lp
->defined
;
1537 label_type
= lp
->referenced
;
1538 lp
->where
= gfc_current_locus
;
1541 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1543 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1548 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1549 && type
== ST_LABEL_FORMAT
)
1551 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1556 lp
->referenced
= type
;
1564 /************** Symbol table management subroutines ****************/
1566 /* Basic details: Fortran 95 requires a potentially unlimited number
1567 of distinct namespaces when compiling a program unit. This case
1568 occurs during a compilation of internal subprograms because all of
1569 the internal subprograms must be read before we can start
1570 generating code for the host.
1572 Given the tricky nature of the Fortran grammar, we must be able to
1573 undo changes made to a symbol table if the current interpretation
1574 of a statement is found to be incorrect. Whenever a symbol is
1575 looked up, we make a copy of it and link to it. All of these
1576 symbols are kept in a singly linked list so that we can commit or
1577 undo the changes at a later time.
1579 A symtree may point to a symbol node outside of its namespace. In
1580 this case, that symbol has been used as a host associated variable
1581 at some previous time. */
1583 /* Allocate a new namespace structure. Copies the implicit types from
1584 PARENT if PARENT_TYPES is set. */
1587 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1591 gfc_intrinsic_op in
;
1594 ns
= gfc_getmem (sizeof (gfc_namespace
));
1595 ns
->sym_root
= NULL
;
1596 ns
->uop_root
= NULL
;
1597 ns
->default_access
= ACCESS_UNKNOWN
;
1598 ns
->parent
= parent
;
1600 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1601 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1603 /* Initialize default implicit types. */
1604 for (i
= 'a'; i
<= 'z'; i
++)
1606 ns
->set_flag
[i
- 'a'] = 0;
1607 ts
= &ns
->default_type
[i
- 'a'];
1609 if (parent_types
&& ns
->parent
!= NULL
)
1611 /* Copy parent settings */
1612 *ts
= ns
->parent
->default_type
[i
- 'a'];
1616 if (gfc_option
.flag_implicit_none
!= 0)
1622 if ('i' <= i
&& i
<= 'n')
1624 ts
->type
= BT_INTEGER
;
1625 ts
->kind
= gfc_default_integer_kind
;
1630 ts
->kind
= gfc_default_real_kind
;
1640 /* Comparison function for symtree nodes. */
1643 compare_symtree (void * _st1
, void * _st2
)
1645 gfc_symtree
*st1
, *st2
;
1647 st1
= (gfc_symtree
*) _st1
;
1648 st2
= (gfc_symtree
*) _st2
;
1650 return strcmp (st1
->name
, st2
->name
);
1654 /* Allocate a new symtree node and associate it with the new symbol. */
1657 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1661 st
= gfc_getmem (sizeof (gfc_symtree
));
1662 st
->name
= gfc_get_string (name
);
1664 gfc_insert_bbt (root
, st
, compare_symtree
);
1669 /* Delete a symbol from the tree. Does not free the symbol itself! */
1672 delete_symtree (gfc_symtree
** root
, const char *name
)
1674 gfc_symtree st
, *st0
;
1676 st0
= gfc_find_symtree (*root
, name
);
1678 st
.name
= gfc_get_string (name
);
1679 gfc_delete_bbt (root
, &st
, compare_symtree
);
1685 /* Given a root symtree node and a name, try to find the symbol within
1686 the namespace. Returns NULL if the symbol is not found. */
1689 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1695 c
= strcmp (name
, st
->name
);
1699 st
= (c
< 0) ? st
->left
: st
->right
;
1706 /* Given a name find a user operator node, creating it if it doesn't
1707 exist. These are much simpler than symbols because they can't be
1708 ambiguous with one another. */
1711 gfc_get_uop (const char *name
)
1716 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1720 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1722 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1723 uop
->name
= gfc_get_string (name
);
1724 uop
->access
= ACCESS_UNKNOWN
;
1725 uop
->ns
= gfc_current_ns
;
1731 /* Given a name find the user operator node. Returns NULL if it does
1735 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1740 ns
= gfc_current_ns
;
1742 st
= gfc_find_symtree (ns
->uop_root
, name
);
1743 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1747 /* Remove a gfc_symbol structure and everything it points to. */
1750 gfc_free_symbol (gfc_symbol
* sym
)
1756 gfc_free_array_spec (sym
->as
);
1758 free_components (sym
->components
);
1760 gfc_free_expr (sym
->value
);
1762 gfc_free_namelist (sym
->namelist
);
1764 gfc_free_namespace (sym
->formal_ns
);
1766 gfc_free_interface (sym
->generic
);
1768 gfc_free_formal_arglist (sym
->formal
);
1774 /* Allocate and initialize a new symbol node. */
1777 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1781 p
= gfc_getmem (sizeof (gfc_symbol
));
1783 gfc_clear_ts (&p
->ts
);
1784 gfc_clear_attr (&p
->attr
);
1787 p
->declared_at
= gfc_current_locus
;
1789 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1790 gfc_internal_error ("new_symbol(): Symbol name too long");
1792 p
->name
= gfc_get_string (name
);
1797 /* Generate an error if a symbol is ambiguous. */
1800 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1803 if (st
->n
.sym
->module
)
1804 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1805 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1807 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1808 "from current program unit", name
, st
->n
.sym
->name
);
1812 /* Search for a symtree starting in the current namespace, resorting to
1813 any parent namespaces if requested by a nonzero parent_flag.
1814 Returns nonzero if the name is ambiguous. */
1817 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1818 gfc_symtree
** result
)
1823 ns
= gfc_current_ns
;
1827 st
= gfc_find_symtree (ns
->sym_root
, name
);
1833 ambiguous_symbol (name
, st
);
1852 /* Same, but returns the symbol instead. */
1855 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1856 gfc_symbol
** result
)
1861 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1866 *result
= st
->n
.sym
;
1872 /* Save symbol with the information necessary to back it out. */
1875 save_symbol_data (gfc_symbol
* sym
)
1878 if (sym
->new || sym
->old_symbol
!= NULL
)
1881 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1882 *(sym
->old_symbol
) = *sym
;
1884 sym
->tlink
= changed_syms
;
1889 /* Given a name, find a symbol, or create it if it does not exist yet
1890 in the current namespace. If the symbol is found we make sure that
1893 The integer return code indicates
1895 1 The symbol name was ambiguous
1896 2 The name meant to be established was already host associated.
1898 So if the return value is nonzero, then an error was issued. */
1901 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1906 /* This doesn't usually happen during resolution. */
1908 ns
= gfc_current_ns
;
1910 /* Try to find the symbol in ns. */
1911 st
= gfc_find_symtree (ns
->sym_root
, name
);
1915 /* If not there, create a new symbol. */
1916 p
= gfc_new_symbol (name
, ns
);
1918 /* Add to the list of tentative symbols. */
1919 p
->old_symbol
= NULL
;
1920 p
->tlink
= changed_syms
;
1925 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1932 /* Make sure the existing symbol is OK. */
1935 ambiguous_symbol (name
, st
);
1941 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1943 /* Symbol is from another namespace. */
1944 gfc_error ("Symbol '%s' at %C has already been host associated",
1951 /* Copy in case this symbol is changed. */
1952 save_symbol_data (p
);
1961 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1967 i
= gfc_get_sym_tree (name
, ns
, &st
);
1972 *result
= st
->n
.sym
;
1979 /* Subroutine that searches for a symbol, creating it if it doesn't
1980 exist, but tries to host-associate the symbol if possible. */
1983 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
1988 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1991 save_symbol_data (st
->n
.sym
);
1997 if (gfc_current_ns
->parent
!= NULL
)
1999 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2010 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2015 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2020 i
= gfc_get_ha_sym_tree (name
, &st
);
2023 *result
= st
->n
.sym
;
2030 /* Return true if both symbols could refer to the same data object. Does
2031 not take account of aliasing due to equivalence statements. */
2034 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2036 /* Aliasing isn't possible if the symbols have different base types. */
2037 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2040 /* Pointers can point to other pointers, target objects and allocatable
2041 objects. Two allocatable objects cannot share the same storage. */
2042 if (lsym
->attr
.pointer
2043 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2045 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2047 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2054 /* Undoes all the changes made to symbols in the current statement.
2055 This subroutine is made simpler due to the fact that attributes are
2056 never removed once added. */
2059 gfc_undo_symbols (void)
2061 gfc_symbol
*p
, *q
, *old
;
2063 for (p
= changed_syms
; p
; p
= q
)
2069 /* Symbol was new. */
2070 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2074 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2076 gfc_free_symbol (p
);
2080 /* Restore previous state of symbol. Just copy simple stuff. */
2082 old
= p
->old_symbol
;
2084 p
->ts
.type
= old
->ts
.type
;
2085 p
->ts
.kind
= old
->ts
.kind
;
2087 p
->attr
= old
->attr
;
2089 if (p
->value
!= old
->value
)
2091 gfc_free_expr (old
->value
);
2095 if (p
->as
!= old
->as
)
2098 gfc_free_array_spec (p
->as
);
2102 p
->generic
= old
->generic
;
2103 p
->component_access
= old
->component_access
;
2105 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2107 gfc_free_namelist (p
->namelist
);
2113 if (p
->namelist_tail
!= old
->namelist_tail
)
2115 gfc_free_namelist (old
->namelist_tail
);
2116 old
->namelist_tail
->next
= NULL
;
2120 p
->namelist_tail
= old
->namelist_tail
;
2122 if (p
->formal
!= old
->formal
)
2124 gfc_free_formal_arglist (p
->formal
);
2125 p
->formal
= old
->formal
;
2128 gfc_free (p
->old_symbol
);
2129 p
->old_symbol
= NULL
;
2133 changed_syms
= NULL
;
2137 /* Makes the changes made in the current statement permanent-- gets
2138 rid of undo information. */
2141 gfc_commit_symbols (void)
2145 for (p
= changed_syms
; p
; p
= q
)
2152 if (p
->old_symbol
!= NULL
)
2154 gfc_free (p
->old_symbol
);
2155 p
->old_symbol
= NULL
;
2159 changed_syms
= NULL
;
2163 /* Recursive function that deletes an entire tree and all the common
2164 head structures it points to. */
2167 free_common_tree (gfc_symtree
* common_tree
)
2169 if (common_tree
== NULL
)
2172 free_common_tree (common_tree
->left
);
2173 free_common_tree (common_tree
->right
);
2175 gfc_free (common_tree
);
2179 /* Recursive function that deletes an entire tree and all the user
2180 operator nodes that it contains. */
2183 free_uop_tree (gfc_symtree
* uop_tree
)
2186 if (uop_tree
== NULL
)
2189 free_uop_tree (uop_tree
->left
);
2190 free_uop_tree (uop_tree
->right
);
2192 gfc_free_interface (uop_tree
->n
.uop
->operator);
2194 gfc_free (uop_tree
->n
.uop
);
2195 gfc_free (uop_tree
);
2199 /* Recursive function that deletes an entire tree and all the symbols
2200 that it contains. */
2203 free_sym_tree (gfc_symtree
* sym_tree
)
2208 if (sym_tree
== NULL
)
2211 free_sym_tree (sym_tree
->left
);
2212 free_sym_tree (sym_tree
->right
);
2214 sym
= sym_tree
->n
.sym
;
2218 gfc_internal_error ("free_sym_tree(): Negative refs");
2220 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2222 /* As formal_ns contains a reference to sym, delete formal_ns just
2223 before the deletion of sym. */
2224 ns
= sym
->formal_ns
;
2225 sym
->formal_ns
= NULL
;
2226 gfc_free_namespace (ns
);
2228 else if (sym
->refs
== 0)
2230 /* Go ahead and delete the symbol. */
2231 gfc_free_symbol (sym
);
2234 gfc_free (sym_tree
);
2238 /* Free a namespace structure and everything below it. Interface
2239 lists associated with intrinsic operators are not freed. These are
2240 taken care of when a specific name is freed. */
2243 gfc_free_namespace (gfc_namespace
* ns
)
2245 gfc_charlen
*cl
, *cl2
;
2246 gfc_namespace
*p
, *q
;
2255 gcc_assert (ns
->refs
== 0);
2257 gfc_free_statements (ns
->code
);
2259 free_sym_tree (ns
->sym_root
);
2260 free_uop_tree (ns
->uop_root
);
2261 free_common_tree (ns
->common_root
);
2263 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2266 gfc_free_expr (cl
->length
);
2270 free_st_labels (ns
->st_labels
);
2272 gfc_free_equiv (ns
->equiv
);
2274 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2275 gfc_free_interface (ns
->operator[i
]);
2277 gfc_free_data (ns
->data
);
2281 /* Recursively free any contained namespaces. */
2287 gfc_free_namespace (q
);
2293 gfc_symbol_init_2 (void)
2296 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2301 gfc_symbol_done_2 (void)
2304 gfc_free_namespace (gfc_current_ns
);
2305 gfc_current_ns
= NULL
;
2309 /* Clear mark bits from symbol nodes associated with a symtree node. */
2312 clear_sym_mark (gfc_symtree
* st
)
2315 st
->n
.sym
->mark
= 0;
2319 /* Recursively traverse the symtree nodes. */
2322 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2328 gfc_traverse_symtree (st
->left
, func
);
2329 gfc_traverse_symtree (st
->right
, func
);
2334 /* Recursive namespace traversal function. */
2337 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2343 if (st
->n
.sym
->mark
== 0)
2344 (*func
) (st
->n
.sym
);
2345 st
->n
.sym
->mark
= 1;
2347 traverse_ns (st
->left
, func
);
2348 traverse_ns (st
->right
, func
);
2352 /* Call a given function for all symbols in the namespace. We take
2353 care that each gfc_symbol node is called exactly once. */
2356 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2359 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2361 traverse_ns (ns
->sym_root
, func
);
2365 /* Return TRUE if the symbol is an automatic variable. */
2367 gfc_is_var_automatic (gfc_symbol
* sym
)
2369 /* Pointer and allocatable variables are never automatic. */
2370 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2372 /* Check for arrays with non-constant size. */
2373 if (sym
->attr
.dimension
&& sym
->as
2374 && !gfc_is_compile_time_shape (sym
->as
))
2376 /* Check for non-constant length character variables. */
2377 if (sym
->ts
.type
== BT_CHARACTER
2379 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2384 /* Given a symbol, mark it as SAVEd if it is allowed. */
2387 save_symbol (gfc_symbol
* sym
)
2390 if (sym
->attr
.use_assoc
)
2393 if (sym
->attr
.in_common
2395 || sym
->attr
.flavor
!= FL_VARIABLE
)
2397 /* Automatic objects are not saved. */
2398 if (gfc_is_var_automatic (sym
))
2400 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2404 /* Mark those symbols which can be SAVEd as such. */
2407 gfc_save_all (gfc_namespace
* ns
)
2410 gfc_traverse_ns (ns
, save_symbol
);
2415 /* Make sure that no changes to symbols are pending. */
2418 gfc_symbol_state(void) {
2420 if (changed_syms
!= NULL
)
2421 gfc_internal_error("Symbol changes still pending!");
2426 /************** Global symbol handling ************/
2429 /* Search a tree for the global symbol. */
2432 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2438 if (strcmp (symbol
->name
, name
) == 0)
2441 s
= gfc_find_gsymbol (symbol
->left
, name
);
2445 s
= gfc_find_gsymbol (symbol
->right
, name
);
2453 /* Compare two global symbols. Used for managing the BB tree. */
2456 gsym_compare (void * _s1
, void * _s2
)
2458 gfc_gsymbol
*s1
, *s2
;
2460 s1
= (gfc_gsymbol
*)_s1
;
2461 s2
= (gfc_gsymbol
*)_s2
;
2462 return strcmp(s1
->name
, s2
->name
);
2466 /* Get a global symbol, creating it if it doesn't exist. */
2469 gfc_get_gsymbol (const char *name
)
2473 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2477 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2478 s
->type
= GSYM_UNKNOWN
;
2479 s
->name
= gfc_get_string (name
);
2481 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);