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", *cray_pointer
= "CRAY POINTER",
267 *cray_pointee
= "CRAY POINTEE", *data
= "DATA";
272 where
= &gfc_current_locus
;
274 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
281 /* Check for attributes not allowed in a BLOCK DATA. */
282 if (gfc_current_state () == COMP_BLOCK_DATA
)
286 if (attr
->in_namelist
)
288 if (attr
->allocatable
)
294 if (attr
->access
== ACCESS_PRIVATE
)
296 if (attr
->access
== ACCESS_PUBLIC
)
298 if (attr
->intent
!= INTENT_UNKNOWN
)
304 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
311 conf (pointer
, target
);
312 conf (pointer
, external
);
313 conf (pointer
, intrinsic
);
314 conf (target
, external
);
315 conf (target
, intrinsic
);
316 conf (external
, dimension
); /* See Fortran 95's R504. */
318 conf (external
, intrinsic
);
319 conf (allocatable
, pointer
);
320 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
321 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
322 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
323 conf (elemental
, recursive
);
325 conf (in_common
, dummy
);
326 conf (in_common
, allocatable
);
327 conf (in_common
, result
);
328 conf (in_common
, save
);
331 conf (dummy
, result
);
333 conf (in_equivalence
, use_assoc
);
334 conf (in_equivalence
, dummy
);
335 conf (in_equivalence
, target
);
336 conf (in_equivalence
, pointer
);
337 conf (in_equivalence
, function
);
338 conf (in_equivalence
, result
);
339 conf (in_equivalence
, entry
);
340 conf (in_equivalence
, allocatable
);
342 conf (in_namelist
, pointer
);
343 conf (in_namelist
, allocatable
);
345 conf (entry
, result
);
347 conf (function
, subroutine
);
349 /* Cray pointer/pointee conflicts. */
350 conf (cray_pointer
, cray_pointee
);
351 conf (cray_pointer
, dimension
);
352 conf (cray_pointer
, pointer
);
353 conf (cray_pointer
, target
);
354 conf (cray_pointer
, allocatable
);
355 conf (cray_pointer
, external
);
356 conf (cray_pointer
, intrinsic
);
357 conf (cray_pointer
, in_namelist
);
358 conf (cray_pointer
, function
);
359 conf (cray_pointer
, subroutine
);
360 conf (cray_pointer
, entry
);
362 conf (cray_pointee
, allocatable
);
363 conf (cray_pointee
, intent
);
364 conf (cray_pointee
, optional
);
365 conf (cray_pointee
, dummy
);
366 conf (cray_pointee
, target
);
367 conf (cray_pointee
, external
);
368 conf (cray_pointee
, intrinsic
);
369 conf (cray_pointee
, pointer
);
370 conf (cray_pointee
, function
);
371 conf (cray_pointee
, subroutine
);
372 conf (cray_pointee
, entry
);
373 conf (cray_pointee
, in_common
);
374 conf (cray_pointee
, in_equivalence
);
377 conf (data
, function
);
379 conf (data
, allocatable
);
380 conf (data
, use_assoc
);
382 a1
= gfc_code2string (flavors
, attr
->flavor
);
384 if (attr
->in_namelist
385 && attr
->flavor
!= FL_VARIABLE
386 && attr
->flavor
!= FL_UNKNOWN
)
393 switch (attr
->flavor
)
420 if (attr
->subroutine
)
433 case PROC_ST_FUNCTION
:
467 if (attr
->intent
!= INTENT_UNKNOWN
)
497 gfc_error ("%s attribute conflicts with %s attribute at %L",
500 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
501 a1
, a2
, name
, where
);
510 /* Mark a symbol as referenced. */
513 gfc_set_sym_referenced (gfc_symbol
* sym
)
515 if (sym
->attr
.referenced
)
518 sym
->attr
.referenced
= 1;
520 /* Remember which order dummy variables are accessed in. */
522 sym
->dummy_order
= next_dummy_order
++;
526 /* Common subroutine called by attribute changing subroutines in order
527 to prevent them from changing a symbol that has been
528 use-associated. Returns zero if it is OK to change the symbol,
532 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
535 if (attr
->use_assoc
== 0)
539 where
= &gfc_current_locus
;
542 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
545 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
552 /* Used to prevent changing the attributes of a symbol after it has been
553 used. This check is only done for dummy variables as only these can be
554 used in specification expressions. Applying this to all symbols causes
555 an error when we reach the body of a contained function. */
558 check_done (symbol_attribute
* attr
, locus
* where
)
561 if (!(attr
->dummy
&& attr
->referenced
))
565 where
= &gfc_current_locus
;
567 gfc_error ("Cannot change attributes of symbol at %L"
568 " after it has been used", where
);
574 /* Generate an error because of a duplicate attribute. */
577 duplicate_attr (const char *attr
, locus
* where
)
581 where
= &gfc_current_locus
;
583 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
588 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
591 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
594 if (attr
->allocatable
)
596 duplicate_attr ("ALLOCATABLE", where
);
600 attr
->allocatable
= 1;
601 return check_conflict (attr
, NULL
, where
);
606 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
609 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
614 duplicate_attr ("DIMENSION", where
);
619 return check_conflict (attr
, name
, where
);
624 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
627 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
632 duplicate_attr ("EXTERNAL", where
);
638 return check_conflict (attr
, NULL
, where
);
643 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
646 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
651 duplicate_attr ("INTRINSIC", where
);
657 return check_conflict (attr
, NULL
, where
);
662 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
665 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
670 duplicate_attr ("OPTIONAL", where
);
675 return check_conflict (attr
, NULL
, where
);
680 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
683 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
687 return check_conflict (attr
, NULL
, where
);
692 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
695 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
698 attr
->cray_pointer
= 1;
699 return check_conflict (attr
, NULL
, where
);
704 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
707 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
710 if (attr
->cray_pointee
)
712 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
713 " statements.", where
);
717 attr
->cray_pointee
= 1;
718 return check_conflict (attr
, NULL
, where
);
723 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
726 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
730 return check_conflict (attr
, name
, where
);
735 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
738 if (check_used (attr
, name
, where
))
744 ("SAVE attribute at %L cannot be specified in a PURE procedure",
751 if (gfc_notify_std (GFC_STD_LEGACY
,
752 "Duplicate SAVE attribute specified at %L",
759 return check_conflict (attr
, name
, where
);
764 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
767 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
772 duplicate_attr ("TARGET", where
);
777 return check_conflict (attr
, NULL
, where
);
782 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
785 if (check_used (attr
, name
, where
))
788 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
790 return check_conflict (attr
, name
, where
);
795 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
798 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
801 /* Duplicate attribute already checked for. */
803 if (check_conflict (attr
, name
, where
) == FAILURE
)
806 if (attr
->flavor
== FL_VARIABLE
)
809 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
813 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
816 /* Duplicate attribute already checked for. */
817 attr
->in_equivalence
= 1;
818 if (check_conflict (attr
, name
, where
) == FAILURE
)
821 if (attr
->flavor
== FL_VARIABLE
)
824 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
829 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
832 if (check_used (attr
, name
, where
))
836 return check_conflict (attr
, name
, where
);
841 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
845 attr
->in_namelist
= 1;
846 return check_conflict (attr
, name
, where
);
851 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
854 if (check_used (attr
, name
, where
))
858 return check_conflict (attr
, name
, where
);
863 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
866 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
870 return check_conflict (attr
, NULL
, where
);
875 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
878 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
882 return check_conflict (attr
, NULL
, where
);
887 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
890 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
894 return check_conflict (attr
, NULL
, where
);
899 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
902 if (check_used (attr
, name
, where
))
907 duplicate_attr ("ENTRY", where
);
912 return check_conflict (attr
, name
, where
);
917 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
920 if (attr
->flavor
!= FL_PROCEDURE
921 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
925 return check_conflict (attr
, name
, where
);
930 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
933 if (attr
->flavor
!= FL_PROCEDURE
934 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
937 attr
->subroutine
= 1;
938 return check_conflict (attr
, name
, where
);
943 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
946 if (attr
->flavor
!= FL_PROCEDURE
947 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
951 return check_conflict (attr
, name
, where
);
955 /* Flavors are special because some flavors are not what Fortran
956 considers attributes and can be reaffirmed multiple times. */
959 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
963 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
964 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
965 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
968 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
971 if (attr
->flavor
!= FL_UNKNOWN
)
974 where
= &gfc_current_locus
;
976 gfc_error ("%s attribute conflicts with %s attribute at %L",
977 gfc_code2string (flavors
, attr
->flavor
),
978 gfc_code2string (flavors
, f
), where
);
985 return check_conflict (attr
, name
, where
);
990 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
991 const char *name
, locus
* where
)
994 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
997 if (attr
->flavor
!= FL_PROCEDURE
998 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1002 where
= &gfc_current_locus
;
1004 if (attr
->proc
!= PROC_UNKNOWN
)
1006 gfc_error ("%s procedure at %L is already declared as %s procedure",
1007 gfc_code2string (procedures
, t
), where
,
1008 gfc_code2string (procedures
, attr
->proc
));
1015 /* Statement functions are always scalar and functions. */
1016 if (t
== PROC_ST_FUNCTION
1017 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1018 || attr
->dimension
))
1021 return check_conflict (attr
, name
, where
);
1026 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1029 if (check_used (attr
, NULL
, where
))
1032 if (attr
->intent
== INTENT_UNKNOWN
)
1034 attr
->intent
= intent
;
1035 return check_conflict (attr
, NULL
, where
);
1039 where
= &gfc_current_locus
;
1041 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1042 gfc_intent_string (attr
->intent
),
1043 gfc_intent_string (intent
), where
);
1049 /* No checks for use-association in public and private statements. */
1052 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1053 const char *name
, locus
* where
)
1056 if (attr
->access
== ACCESS_UNKNOWN
)
1058 attr
->access
= access
;
1059 return check_conflict (attr
, name
, where
);
1063 where
= &gfc_current_locus
;
1064 gfc_error ("ACCESS specification at %L was already specified", where
);
1071 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1072 gfc_formal_arglist
* formal
, locus
* where
)
1075 if (check_used (&sym
->attr
, sym
->name
, where
))
1079 where
= &gfc_current_locus
;
1081 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1082 && sym
->attr
.if_source
!= IFSRC_DECL
)
1084 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1089 sym
->formal
= formal
;
1090 sym
->attr
.if_source
= source
;
1096 /* Add a type to a symbol. */
1099 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1103 /* TODO: This is legal if it is reaffirming an implicit type.
1104 if (check_done (&sym->attr, where))
1108 where
= &gfc_current_locus
;
1110 if (sym
->ts
.type
!= BT_UNKNOWN
)
1112 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1113 where
, gfc_basic_typename (sym
->ts
.type
));
1117 flavor
= sym
->attr
.flavor
;
1119 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1120 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1121 && sym
->attr
.subroutine
)
1122 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1124 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1133 /* Clears all attributes. */
1136 gfc_clear_attr (symbol_attribute
* attr
)
1138 memset (attr
, 0, sizeof(symbol_attribute
));
1142 /* Check for missing attributes in the new symbol. Currently does
1143 nothing, but it's not clear that it is unnecessary yet. */
1146 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1147 locus
* where ATTRIBUTE_UNUSED
)
1154 /* Copy an attribute to a symbol attribute, bit by bit. Some
1155 attributes have a lot of side-effects but cannot be present given
1156 where we are called from, so we ignore some bits. */
1159 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1162 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1165 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1167 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1169 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1171 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1173 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1175 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1177 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1182 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1185 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1188 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1190 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1192 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1195 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1197 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1199 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1201 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1204 if (src
->flavor
!= FL_UNKNOWN
1205 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1208 if (src
->intent
!= INTENT_UNKNOWN
1209 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1212 if (src
->access
!= ACCESS_UNKNOWN
1213 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1216 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1219 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1221 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1224 /* The subroutines that set these bits also cause flavors to be set,
1225 and that has already happened in the original, so don't let it
1230 dest
->intrinsic
= 1;
1239 /************** Component name management ************/
1241 /* Component names of a derived type form their own little namespaces
1242 that are separate from all other spaces. The space is composed of
1243 a singly linked list of gfc_component structures whose head is
1244 located in the parent symbol. */
1247 /* Add a component name to a symbol. The call fails if the name is
1248 already present. On success, the component pointer is modified to
1249 point to the additional component structure. */
1252 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1254 gfc_component
*p
, *tail
;
1258 for (p
= sym
->components
; p
; p
= p
->next
)
1260 if (strcmp (p
->name
, name
) == 0)
1262 gfc_error ("Component '%s' at %C already declared at %L",
1270 /* Allocate a new component. */
1271 p
= gfc_get_component ();
1274 sym
->components
= p
;
1278 p
->name
= gfc_get_string (name
);
1279 p
->loc
= gfc_current_locus
;
1286 /* Recursive function to switch derived types of all symbol in a
1290 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1298 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1299 sym
->ts
.derived
= to
;
1301 switch_types (st
->left
, from
, to
);
1302 switch_types (st
->right
, from
, to
);
1306 /* This subroutine is called when a derived type is used in order to
1307 make the final determination about which version to use. The
1308 standard requires that a type be defined before it is 'used', but
1309 such types can appear in IMPLICIT statements before the actual
1310 definition. 'Using' in this context means declaring a variable to
1311 be that type or using the type constructor.
1313 If a type is used and the components haven't been defined, then we
1314 have to have a derived type in a parent unit. We find the node in
1315 the other namespace and point the symtree node in this namespace to
1316 that node. Further reference to this name point to the correct
1317 node. If we can't find the node in a parent namespace, then we have
1320 This subroutine takes a pointer to a symbol node and returns a
1321 pointer to the translated node or NULL for an error. Usually there
1322 is no translation and we return the node we were passed. */
1325 gfc_use_derived (gfc_symbol
* sym
)
1332 if (sym
->components
!= NULL
)
1333 return sym
; /* Already defined. */
1335 if (sym
->ns
->parent
== NULL
)
1338 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1340 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1344 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1347 /* Get rid of symbol sym, translating all references to s. */
1348 for (i
= 0; i
< GFC_LETTERS
; i
++)
1350 t
= &sym
->ns
->default_type
[i
];
1351 if (t
->derived
== sym
)
1355 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1360 /* Unlink from list of modified symbols. */
1361 if (changed_syms
== sym
)
1362 changed_syms
= sym
->tlink
;
1364 for (p
= changed_syms
; p
; p
= p
->tlink
)
1365 if (p
->tlink
== sym
)
1367 p
->tlink
= sym
->tlink
;
1371 switch_types (sym
->ns
->sym_root
, sym
, s
);
1373 /* TODO: Also have to replace sym -> s in other lists like
1374 namelists, common lists and interface lists. */
1375 gfc_free_symbol (sym
);
1380 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1386 /* Given a derived type node and a component name, try to locate the
1387 component structure. Returns the NULL pointer if the component is
1388 not found or the components are private. */
1391 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1398 sym
= gfc_use_derived (sym
);
1403 for (p
= sym
->components
; p
; p
= p
->next
)
1404 if (strcmp (p
->name
, name
) == 0)
1408 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1412 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1414 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1424 /* Given a symbol, free all of the component structures and everything
1428 free_components (gfc_component
* p
)
1436 gfc_free_array_spec (p
->as
);
1437 gfc_free_expr (p
->initializer
);
1444 /* Set component attributes from a standard symbol attribute
1448 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1451 c
->dimension
= attr
->dimension
;
1452 c
->pointer
= attr
->pointer
;
1456 /* Get a standard symbol attribute structure given the component
1460 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1463 gfc_clear_attr (attr
);
1464 attr
->dimension
= c
->dimension
;
1465 attr
->pointer
= c
->pointer
;
1469 /******************** Statement label management ********************/
1471 /* Free a single gfc_st_label structure, making sure the list is not
1472 messed up. This function is called only when some parse error
1476 gfc_free_st_label (gfc_st_label
* l
)
1483 (l
->prev
->next
= l
->next
);
1486 (l
->next
->prev
= l
->prev
);
1488 if (l
->format
!= NULL
)
1489 gfc_free_expr (l
->format
);
1493 /* Free a whole list of gfc_st_label structures. */
1496 free_st_labels (gfc_st_label
* l1
)
1503 if (l1
->format
!= NULL
)
1504 gfc_free_expr (l1
->format
);
1510 /* Given a label number, search for and return a pointer to the label
1511 structure, creating it if it does not exist. */
1514 gfc_get_st_label (int labelno
)
1518 /* First see if the label is already in this namespace. */
1519 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1520 if (lp
->value
== labelno
)
1525 lp
= gfc_getmem (sizeof (gfc_st_label
));
1527 lp
->value
= labelno
;
1528 lp
->defined
= ST_LABEL_UNKNOWN
;
1529 lp
->referenced
= ST_LABEL_UNKNOWN
;
1532 lp
->next
= gfc_current_ns
->st_labels
;
1533 if (gfc_current_ns
->st_labels
)
1534 gfc_current_ns
->st_labels
->prev
= lp
;
1535 gfc_current_ns
->st_labels
= lp
;
1541 /* Called when a statement with a statement label is about to be
1542 accepted. We add the label to the list of the current namespace,
1543 making sure it hasn't been defined previously and referenced
1547 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1551 labelno
= lp
->value
;
1553 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1554 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1555 &lp
->where
, label_locus
);
1558 lp
->where
= *label_locus
;
1562 case ST_LABEL_FORMAT
:
1563 if (lp
->referenced
== ST_LABEL_TARGET
)
1564 gfc_error ("Label %d at %C already referenced as branch target",
1567 lp
->defined
= ST_LABEL_FORMAT
;
1571 case ST_LABEL_TARGET
:
1572 if (lp
->referenced
== ST_LABEL_FORMAT
)
1573 gfc_error ("Label %d at %C already referenced as a format label",
1576 lp
->defined
= ST_LABEL_TARGET
;
1581 lp
->defined
= ST_LABEL_BAD_TARGET
;
1582 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1588 /* Reference a label. Given a label and its type, see if that
1589 reference is consistent with what is known about that label,
1590 updating the unknown state. Returns FAILURE if something goes
1594 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1596 gfc_sl_type label_type
;
1603 labelno
= lp
->value
;
1605 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1606 label_type
= lp
->defined
;
1609 label_type
= lp
->referenced
;
1610 lp
->where
= gfc_current_locus
;
1613 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1615 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1620 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1621 && type
== ST_LABEL_FORMAT
)
1623 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1628 lp
->referenced
= type
;
1636 /************** Symbol table management subroutines ****************/
1638 /* Basic details: Fortran 95 requires a potentially unlimited number
1639 of distinct namespaces when compiling a program unit. This case
1640 occurs during a compilation of internal subprograms because all of
1641 the internal subprograms must be read before we can start
1642 generating code for the host.
1644 Given the tricky nature of the Fortran grammar, we must be able to
1645 undo changes made to a symbol table if the current interpretation
1646 of a statement is found to be incorrect. Whenever a symbol is
1647 looked up, we make a copy of it and link to it. All of these
1648 symbols are kept in a singly linked list so that we can commit or
1649 undo the changes at a later time.
1651 A symtree may point to a symbol node outside of its namespace. In
1652 this case, that symbol has been used as a host associated variable
1653 at some previous time. */
1655 /* Allocate a new namespace structure. Copies the implicit types from
1656 PARENT if PARENT_TYPES is set. */
1659 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1663 gfc_intrinsic_op in
;
1666 ns
= gfc_getmem (sizeof (gfc_namespace
));
1667 ns
->sym_root
= NULL
;
1668 ns
->uop_root
= NULL
;
1669 ns
->default_access
= ACCESS_UNKNOWN
;
1670 ns
->parent
= parent
;
1672 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1673 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1675 /* Initialize default implicit types. */
1676 for (i
= 'a'; i
<= 'z'; i
++)
1678 ns
->set_flag
[i
- 'a'] = 0;
1679 ts
= &ns
->default_type
[i
- 'a'];
1681 if (parent_types
&& ns
->parent
!= NULL
)
1683 /* Copy parent settings */
1684 *ts
= ns
->parent
->default_type
[i
- 'a'];
1688 if (gfc_option
.flag_implicit_none
!= 0)
1694 if ('i' <= i
&& i
<= 'n')
1696 ts
->type
= BT_INTEGER
;
1697 ts
->kind
= gfc_default_integer_kind
;
1702 ts
->kind
= gfc_default_real_kind
;
1712 /* Comparison function for symtree nodes. */
1715 compare_symtree (void * _st1
, void * _st2
)
1717 gfc_symtree
*st1
, *st2
;
1719 st1
= (gfc_symtree
*) _st1
;
1720 st2
= (gfc_symtree
*) _st2
;
1722 return strcmp (st1
->name
, st2
->name
);
1726 /* Allocate a new symtree node and associate it with the new symbol. */
1729 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1733 st
= gfc_getmem (sizeof (gfc_symtree
));
1734 st
->name
= gfc_get_string (name
);
1736 gfc_insert_bbt (root
, st
, compare_symtree
);
1741 /* Delete a symbol from the tree. Does not free the symbol itself! */
1744 delete_symtree (gfc_symtree
** root
, const char *name
)
1746 gfc_symtree st
, *st0
;
1748 st0
= gfc_find_symtree (*root
, name
);
1750 st
.name
= gfc_get_string (name
);
1751 gfc_delete_bbt (root
, &st
, compare_symtree
);
1757 /* Given a root symtree node and a name, try to find the symbol within
1758 the namespace. Returns NULL if the symbol is not found. */
1761 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1767 c
= strcmp (name
, st
->name
);
1771 st
= (c
< 0) ? st
->left
: st
->right
;
1778 /* Given a name find a user operator node, creating it if it doesn't
1779 exist. These are much simpler than symbols because they can't be
1780 ambiguous with one another. */
1783 gfc_get_uop (const char *name
)
1788 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1792 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1794 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1795 uop
->name
= gfc_get_string (name
);
1796 uop
->access
= ACCESS_UNKNOWN
;
1797 uop
->ns
= gfc_current_ns
;
1803 /* Given a name find the user operator node. Returns NULL if it does
1807 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1812 ns
= gfc_current_ns
;
1814 st
= gfc_find_symtree (ns
->uop_root
, name
);
1815 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1819 /* Remove a gfc_symbol structure and everything it points to. */
1822 gfc_free_symbol (gfc_symbol
* sym
)
1828 gfc_free_array_spec (sym
->as
);
1830 free_components (sym
->components
);
1832 gfc_free_expr (sym
->value
);
1834 gfc_free_namelist (sym
->namelist
);
1836 gfc_free_namespace (sym
->formal_ns
);
1838 gfc_free_interface (sym
->generic
);
1840 gfc_free_formal_arglist (sym
->formal
);
1846 /* Allocate and initialize a new symbol node. */
1849 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1853 p
= gfc_getmem (sizeof (gfc_symbol
));
1855 gfc_clear_ts (&p
->ts
);
1856 gfc_clear_attr (&p
->attr
);
1859 p
->declared_at
= gfc_current_locus
;
1861 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1862 gfc_internal_error ("new_symbol(): Symbol name too long");
1864 p
->name
= gfc_get_string (name
);
1869 /* Generate an error if a symbol is ambiguous. */
1872 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1875 if (st
->n
.sym
->module
)
1876 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1877 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1879 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1880 "from current program unit", name
, st
->n
.sym
->name
);
1884 /* Search for a symtree starting in the current namespace, resorting to
1885 any parent namespaces if requested by a nonzero parent_flag.
1886 Returns nonzero if the name is ambiguous. */
1889 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1890 gfc_symtree
** result
)
1895 ns
= gfc_current_ns
;
1899 st
= gfc_find_symtree (ns
->sym_root
, name
);
1905 ambiguous_symbol (name
, st
);
1924 /* Same, but returns the symbol instead. */
1927 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1928 gfc_symbol
** result
)
1933 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1938 *result
= st
->n
.sym
;
1944 /* Save symbol with the information necessary to back it out. */
1947 save_symbol_data (gfc_symbol
* sym
)
1950 if (sym
->new || sym
->old_symbol
!= NULL
)
1953 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1954 *(sym
->old_symbol
) = *sym
;
1956 sym
->tlink
= changed_syms
;
1961 /* Given a name, find a symbol, or create it if it does not exist yet
1962 in the current namespace. If the symbol is found we make sure that
1965 The integer return code indicates
1967 1 The symbol name was ambiguous
1968 2 The name meant to be established was already host associated.
1970 So if the return value is nonzero, then an error was issued. */
1973 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1978 /* This doesn't usually happen during resolution. */
1980 ns
= gfc_current_ns
;
1982 /* Try to find the symbol in ns. */
1983 st
= gfc_find_symtree (ns
->sym_root
, name
);
1987 /* If not there, create a new symbol. */
1988 p
= gfc_new_symbol (name
, ns
);
1990 /* Add to the list of tentative symbols. */
1991 p
->old_symbol
= NULL
;
1992 p
->tlink
= changed_syms
;
1997 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2004 /* Make sure the existing symbol is OK. */
2007 ambiguous_symbol (name
, st
);
2013 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2015 /* Symbol is from another namespace. */
2016 gfc_error ("Symbol '%s' at %C has already been host associated",
2023 /* Copy in case this symbol is changed. */
2024 save_symbol_data (p
);
2033 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2039 i
= gfc_get_sym_tree (name
, ns
, &st
);
2044 *result
= st
->n
.sym
;
2051 /* Subroutine that searches for a symbol, creating it if it doesn't
2052 exist, but tries to host-associate the symbol if possible. */
2055 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2060 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2063 save_symbol_data (st
->n
.sym
);
2069 if (gfc_current_ns
->parent
!= NULL
)
2071 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2082 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2087 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2092 i
= gfc_get_ha_sym_tree (name
, &st
);
2095 *result
= st
->n
.sym
;
2102 /* Return true if both symbols could refer to the same data object. Does
2103 not take account of aliasing due to equivalence statements. */
2106 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2108 /* Aliasing isn't possible if the symbols have different base types. */
2109 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2112 /* Pointers can point to other pointers, target objects and allocatable
2113 objects. Two allocatable objects cannot share the same storage. */
2114 if (lsym
->attr
.pointer
2115 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2117 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2119 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2126 /* Undoes all the changes made to symbols in the current statement.
2127 This subroutine is made simpler due to the fact that attributes are
2128 never removed once added. */
2131 gfc_undo_symbols (void)
2133 gfc_symbol
*p
, *q
, *old
;
2135 for (p
= changed_syms
; p
; p
= q
)
2141 /* Symbol was new. */
2142 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2146 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2148 gfc_free_symbol (p
);
2152 /* Restore previous state of symbol. Just copy simple stuff. */
2154 old
= p
->old_symbol
;
2156 p
->ts
.type
= old
->ts
.type
;
2157 p
->ts
.kind
= old
->ts
.kind
;
2159 p
->attr
= old
->attr
;
2161 if (p
->value
!= old
->value
)
2163 gfc_free_expr (old
->value
);
2167 if (p
->as
!= old
->as
)
2170 gfc_free_array_spec (p
->as
);
2174 p
->generic
= old
->generic
;
2175 p
->component_access
= old
->component_access
;
2177 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2179 gfc_free_namelist (p
->namelist
);
2185 if (p
->namelist_tail
!= old
->namelist_tail
)
2187 gfc_free_namelist (old
->namelist_tail
);
2188 old
->namelist_tail
->next
= NULL
;
2192 p
->namelist_tail
= old
->namelist_tail
;
2194 if (p
->formal
!= old
->formal
)
2196 gfc_free_formal_arglist (p
->formal
);
2197 p
->formal
= old
->formal
;
2200 gfc_free (p
->old_symbol
);
2201 p
->old_symbol
= NULL
;
2205 changed_syms
= NULL
;
2209 /* Makes the changes made in the current statement permanent-- gets
2210 rid of undo information. */
2213 gfc_commit_symbols (void)
2217 for (p
= changed_syms
; p
; p
= q
)
2224 if (p
->old_symbol
!= NULL
)
2226 gfc_free (p
->old_symbol
);
2227 p
->old_symbol
= NULL
;
2231 changed_syms
= NULL
;
2235 /* Recursive function that deletes an entire tree and all the common
2236 head structures it points to. */
2239 free_common_tree (gfc_symtree
* common_tree
)
2241 if (common_tree
== NULL
)
2244 free_common_tree (common_tree
->left
);
2245 free_common_tree (common_tree
->right
);
2247 gfc_free (common_tree
);
2251 /* Recursive function that deletes an entire tree and all the user
2252 operator nodes that it contains. */
2255 free_uop_tree (gfc_symtree
* uop_tree
)
2258 if (uop_tree
== NULL
)
2261 free_uop_tree (uop_tree
->left
);
2262 free_uop_tree (uop_tree
->right
);
2264 gfc_free_interface (uop_tree
->n
.uop
->operator);
2266 gfc_free (uop_tree
->n
.uop
);
2267 gfc_free (uop_tree
);
2271 /* Recursive function that deletes an entire tree and all the symbols
2272 that it contains. */
2275 free_sym_tree (gfc_symtree
* sym_tree
)
2280 if (sym_tree
== NULL
)
2283 free_sym_tree (sym_tree
->left
);
2284 free_sym_tree (sym_tree
->right
);
2286 sym
= sym_tree
->n
.sym
;
2290 gfc_internal_error ("free_sym_tree(): Negative refs");
2292 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2294 /* As formal_ns contains a reference to sym, delete formal_ns just
2295 before the deletion of sym. */
2296 ns
= sym
->formal_ns
;
2297 sym
->formal_ns
= NULL
;
2298 gfc_free_namespace (ns
);
2300 else if (sym
->refs
== 0)
2302 /* Go ahead and delete the symbol. */
2303 gfc_free_symbol (sym
);
2306 gfc_free (sym_tree
);
2310 /* Free a derived type list. */
2313 gfc_free_dt_list (gfc_dt_list
* dt
)
2325 /* Free a namespace structure and everything below it. Interface
2326 lists associated with intrinsic operators are not freed. These are
2327 taken care of when a specific name is freed. */
2330 gfc_free_namespace (gfc_namespace
* ns
)
2332 gfc_charlen
*cl
, *cl2
;
2333 gfc_namespace
*p
, *q
;
2342 gcc_assert (ns
->refs
== 0);
2344 gfc_free_statements (ns
->code
);
2346 free_sym_tree (ns
->sym_root
);
2347 free_uop_tree (ns
->uop_root
);
2348 free_common_tree (ns
->common_root
);
2350 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2353 gfc_free_expr (cl
->length
);
2357 free_st_labels (ns
->st_labels
);
2359 gfc_free_equiv (ns
->equiv
);
2361 gfc_free_dt_list (ns
->derived_types
);
2363 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2364 gfc_free_interface (ns
->operator[i
]);
2366 gfc_free_data (ns
->data
);
2370 /* Recursively free any contained namespaces. */
2376 gfc_free_namespace (q
);
2382 gfc_symbol_init_2 (void)
2385 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2390 gfc_symbol_done_2 (void)
2393 gfc_free_namespace (gfc_current_ns
);
2394 gfc_current_ns
= NULL
;
2398 /* Clear mark bits from symbol nodes associated with a symtree node. */
2401 clear_sym_mark (gfc_symtree
* st
)
2404 st
->n
.sym
->mark
= 0;
2408 /* Recursively traverse the symtree nodes. */
2411 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2417 gfc_traverse_symtree (st
->left
, func
);
2418 gfc_traverse_symtree (st
->right
, func
);
2423 /* Recursive namespace traversal function. */
2426 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2432 if (st
->n
.sym
->mark
== 0)
2433 (*func
) (st
->n
.sym
);
2434 st
->n
.sym
->mark
= 1;
2436 traverse_ns (st
->left
, func
);
2437 traverse_ns (st
->right
, func
);
2441 /* Call a given function for all symbols in the namespace. We take
2442 care that each gfc_symbol node is called exactly once. */
2445 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2448 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2450 traverse_ns (ns
->sym_root
, func
);
2454 /* Return TRUE if the symbol is an automatic variable. */
2456 gfc_is_var_automatic (gfc_symbol
* sym
)
2458 /* Pointer and allocatable variables are never automatic. */
2459 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2461 /* Check for arrays with non-constant size. */
2462 if (sym
->attr
.dimension
&& sym
->as
2463 && !gfc_is_compile_time_shape (sym
->as
))
2465 /* Check for non-constant length character variables. */
2466 if (sym
->ts
.type
== BT_CHARACTER
2468 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2473 /* Given a symbol, mark it as SAVEd if it is allowed. */
2476 save_symbol (gfc_symbol
* sym
)
2479 if (sym
->attr
.use_assoc
)
2482 if (sym
->attr
.in_common
2484 || sym
->attr
.flavor
!= FL_VARIABLE
)
2486 /* Automatic objects are not saved. */
2487 if (gfc_is_var_automatic (sym
))
2489 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2493 /* Mark those symbols which can be SAVEd as such. */
2496 gfc_save_all (gfc_namespace
* ns
)
2499 gfc_traverse_ns (ns
, save_symbol
);
2504 /* Make sure that no changes to symbols are pending. */
2507 gfc_symbol_state(void) {
2509 if (changed_syms
!= NULL
)
2510 gfc_internal_error("Symbol changes still pending!");
2515 /************** Global symbol handling ************/
2518 /* Search a tree for the global symbol. */
2521 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2527 if (strcmp (symbol
->name
, name
) == 0)
2530 s
= gfc_find_gsymbol (symbol
->left
, name
);
2534 s
= gfc_find_gsymbol (symbol
->right
, name
);
2542 /* Compare two global symbols. Used for managing the BB tree. */
2545 gsym_compare (void * _s1
, void * _s2
)
2547 gfc_gsymbol
*s1
, *s2
;
2549 s1
= (gfc_gsymbol
*)_s1
;
2550 s2
= (gfc_gsymbol
*)_s2
;
2551 return strcmp(s1
->name
, s2
->name
);
2555 /* Get a global symbol, creating it if it doesn't exist. */
2558 gfc_get_gsymbol (const char *name
)
2562 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2566 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2567 s
->type
= GSYM_UNKNOWN
;
2568 s
->name
= gfc_get_string (name
);
2570 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);