1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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 (pointer
, elemental
);
316 conf (target
, external
);
317 conf (target
, intrinsic
);
318 conf (external
, dimension
); /* See Fortran 95's R504. */
320 conf (external
, intrinsic
);
322 if (attr
->if_source
|| attr
->contained
)
324 conf (external
, subroutine
);
325 conf (external
, function
);
328 conf (allocatable
, pointer
);
329 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
330 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
331 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
332 conf (elemental
, recursive
);
334 conf (in_common
, dummy
);
335 conf (in_common
, allocatable
);
336 conf (in_common
, result
);
337 conf (in_common
, save
);
340 conf (dummy
, result
);
342 conf (in_equivalence
, use_assoc
);
343 conf (in_equivalence
, dummy
);
344 conf (in_equivalence
, target
);
345 conf (in_equivalence
, pointer
);
346 conf (in_equivalence
, function
);
347 conf (in_equivalence
, result
);
348 conf (in_equivalence
, entry
);
349 conf (in_equivalence
, allocatable
);
351 conf (in_namelist
, pointer
);
352 conf (in_namelist
, allocatable
);
354 conf (entry
, result
);
356 conf (function
, subroutine
);
358 /* Cray pointer/pointee conflicts. */
359 conf (cray_pointer
, cray_pointee
);
360 conf (cray_pointer
, dimension
);
361 conf (cray_pointer
, pointer
);
362 conf (cray_pointer
, target
);
363 conf (cray_pointer
, allocatable
);
364 conf (cray_pointer
, external
);
365 conf (cray_pointer
, intrinsic
);
366 conf (cray_pointer
, in_namelist
);
367 conf (cray_pointer
, function
);
368 conf (cray_pointer
, subroutine
);
369 conf (cray_pointer
, entry
);
371 conf (cray_pointee
, allocatable
);
372 conf (cray_pointee
, intent
);
373 conf (cray_pointee
, optional
);
374 conf (cray_pointee
, dummy
);
375 conf (cray_pointee
, target
);
376 conf (cray_pointee
, external
);
377 conf (cray_pointee
, intrinsic
);
378 conf (cray_pointee
, pointer
);
379 conf (cray_pointee
, function
);
380 conf (cray_pointee
, subroutine
);
381 conf (cray_pointee
, entry
);
382 conf (cray_pointee
, in_common
);
383 conf (cray_pointee
, in_equivalence
);
386 conf (data
, function
);
388 conf (data
, allocatable
);
389 conf (data
, use_assoc
);
391 a1
= gfc_code2string (flavors
, attr
->flavor
);
393 if (attr
->in_namelist
394 && attr
->flavor
!= FL_VARIABLE
395 && attr
->flavor
!= FL_UNKNOWN
)
402 switch (attr
->flavor
)
429 if (attr
->subroutine
)
442 case PROC_ST_FUNCTION
:
476 if (attr
->intent
!= INTENT_UNKNOWN
)
506 gfc_error ("%s attribute conflicts with %s attribute at %L",
509 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
510 a1
, a2
, name
, where
);
519 /* Mark a symbol as referenced. */
522 gfc_set_sym_referenced (gfc_symbol
* sym
)
524 if (sym
->attr
.referenced
)
527 sym
->attr
.referenced
= 1;
529 /* Remember which order dummy variables are accessed in. */
531 sym
->dummy_order
= next_dummy_order
++;
535 /* Common subroutine called by attribute changing subroutines in order
536 to prevent them from changing a symbol that has been
537 use-associated. Returns zero if it is OK to change the symbol,
541 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
544 if (attr
->use_assoc
== 0)
548 where
= &gfc_current_locus
;
551 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
554 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
561 /* Used to prevent changing the attributes of a symbol after it has been
562 used. This check is only done for dummy variables as only these can be
563 used in specification expressions. Applying this to all symbols causes
564 an error when we reach the body of a contained function. */
567 check_done (symbol_attribute
* attr
, locus
* where
)
570 if (!(attr
->dummy
&& attr
->referenced
))
574 where
= &gfc_current_locus
;
576 gfc_error ("Cannot change attributes of symbol at %L"
577 " after it has been used", where
);
583 /* Generate an error because of a duplicate attribute. */
586 duplicate_attr (const char *attr
, locus
* where
)
590 where
= &gfc_current_locus
;
592 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
597 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
600 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
603 return check_conflict (attr
, NULL
, where
);
607 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
610 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
613 if (attr
->allocatable
)
615 duplicate_attr ("ALLOCATABLE", where
);
619 attr
->allocatable
= 1;
620 return check_conflict (attr
, NULL
, where
);
625 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
628 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
633 duplicate_attr ("DIMENSION", where
);
638 return check_conflict (attr
, name
, where
);
643 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
646 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
651 duplicate_attr ("EXTERNAL", where
);
657 return check_conflict (attr
, NULL
, where
);
662 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
665 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
670 duplicate_attr ("INTRINSIC", where
);
676 return check_conflict (attr
, NULL
, where
);
681 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
684 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
689 duplicate_attr ("OPTIONAL", where
);
694 return check_conflict (attr
, NULL
, where
);
699 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
702 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
706 return check_conflict (attr
, NULL
, where
);
711 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
714 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
717 attr
->cray_pointer
= 1;
718 return check_conflict (attr
, NULL
, where
);
723 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
726 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
729 if (attr
->cray_pointee
)
731 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
732 " statements.", where
);
736 attr
->cray_pointee
= 1;
737 return check_conflict (attr
, NULL
, where
);
742 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
745 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
749 return check_conflict (attr
, name
, where
);
754 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
757 if (check_used (attr
, name
, where
))
763 ("SAVE attribute at %L cannot be specified in a PURE procedure",
770 if (gfc_notify_std (GFC_STD_LEGACY
,
771 "Duplicate SAVE attribute specified at %L",
778 return check_conflict (attr
, name
, where
);
783 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
786 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
791 duplicate_attr ("TARGET", where
);
796 return check_conflict (attr
, NULL
, where
);
801 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
804 if (check_used (attr
, name
, where
))
807 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
809 return check_conflict (attr
, name
, where
);
814 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
817 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
820 /* Duplicate attribute already checked for. */
822 if (check_conflict (attr
, name
, where
) == FAILURE
)
825 if (attr
->flavor
== FL_VARIABLE
)
828 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
832 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
835 /* Duplicate attribute already checked for. */
836 attr
->in_equivalence
= 1;
837 if (check_conflict (attr
, name
, where
) == FAILURE
)
840 if (attr
->flavor
== FL_VARIABLE
)
843 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
848 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
851 if (check_used (attr
, name
, where
))
855 return check_conflict (attr
, name
, where
);
860 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
864 attr
->in_namelist
= 1;
865 return check_conflict (attr
, name
, where
);
870 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
873 if (check_used (attr
, name
, where
))
877 return check_conflict (attr
, name
, where
);
882 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
885 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
889 return check_conflict (attr
, NULL
, where
);
894 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
897 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
901 return check_conflict (attr
, NULL
, where
);
906 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
909 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
913 return check_conflict (attr
, NULL
, where
);
918 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
921 if (check_used (attr
, name
, where
))
926 duplicate_attr ("ENTRY", where
);
931 return check_conflict (attr
, name
, where
);
936 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
939 if (attr
->flavor
!= FL_PROCEDURE
940 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
944 return check_conflict (attr
, name
, where
);
949 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
952 if (attr
->flavor
!= FL_PROCEDURE
953 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
956 attr
->subroutine
= 1;
957 return check_conflict (attr
, name
, where
);
962 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
965 if (attr
->flavor
!= FL_PROCEDURE
966 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
970 return check_conflict (attr
, name
, where
);
974 /* Flavors are special because some flavors are not what Fortran
975 considers attributes and can be reaffirmed multiple times. */
978 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
982 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
983 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
984 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
987 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
990 if (attr
->flavor
!= FL_UNKNOWN
)
993 where
= &gfc_current_locus
;
995 gfc_error ("%s attribute conflicts with %s attribute at %L",
996 gfc_code2string (flavors
, attr
->flavor
),
997 gfc_code2string (flavors
, f
), where
);
1004 return check_conflict (attr
, name
, where
);
1009 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1010 const char *name
, locus
* where
)
1013 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1016 if (attr
->flavor
!= FL_PROCEDURE
1017 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1021 where
= &gfc_current_locus
;
1023 if (attr
->proc
!= PROC_UNKNOWN
)
1025 gfc_error ("%s procedure at %L is already declared as %s procedure",
1026 gfc_code2string (procedures
, t
), where
,
1027 gfc_code2string (procedures
, attr
->proc
));
1034 /* Statement functions are always scalar and functions. */
1035 if (t
== PROC_ST_FUNCTION
1036 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1037 || attr
->dimension
))
1040 return check_conflict (attr
, name
, where
);
1045 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1048 if (check_used (attr
, NULL
, where
))
1051 if (attr
->intent
== INTENT_UNKNOWN
)
1053 attr
->intent
= intent
;
1054 return check_conflict (attr
, NULL
, where
);
1058 where
= &gfc_current_locus
;
1060 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1061 gfc_intent_string (attr
->intent
),
1062 gfc_intent_string (intent
), where
);
1068 /* No checks for use-association in public and private statements. */
1071 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1072 const char *name
, locus
* where
)
1075 if (attr
->access
== ACCESS_UNKNOWN
)
1077 attr
->access
= access
;
1078 return check_conflict (attr
, name
, where
);
1082 where
= &gfc_current_locus
;
1083 gfc_error ("ACCESS specification at %L was already specified", where
);
1090 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1091 gfc_formal_arglist
* formal
, locus
* where
)
1094 if (check_used (&sym
->attr
, sym
->name
, where
))
1098 where
= &gfc_current_locus
;
1100 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1101 && sym
->attr
.if_source
!= IFSRC_DECL
)
1103 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1108 sym
->formal
= formal
;
1109 sym
->attr
.if_source
= source
;
1115 /* Add a type to a symbol. */
1118 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1122 /* TODO: This is legal if it is reaffirming an implicit type.
1123 if (check_done (&sym->attr, where))
1127 where
= &gfc_current_locus
;
1129 if (sym
->ts
.type
!= BT_UNKNOWN
)
1131 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1132 where
, gfc_basic_typename (sym
->ts
.type
));
1136 flavor
= sym
->attr
.flavor
;
1138 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1139 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1140 && sym
->attr
.subroutine
)
1141 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1143 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1152 /* Clears all attributes. */
1155 gfc_clear_attr (symbol_attribute
* attr
)
1157 memset (attr
, 0, sizeof(symbol_attribute
));
1161 /* Check for missing attributes in the new symbol. Currently does
1162 nothing, but it's not clear that it is unnecessary yet. */
1165 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1166 locus
* where ATTRIBUTE_UNUSED
)
1173 /* Copy an attribute to a symbol attribute, bit by bit. Some
1174 attributes have a lot of side-effects but cannot be present given
1175 where we are called from, so we ignore some bits. */
1178 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1181 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1184 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1186 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1188 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1190 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1192 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1194 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1196 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1201 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1204 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1207 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1209 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1211 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1214 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1216 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1218 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1220 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1223 if (src
->flavor
!= FL_UNKNOWN
1224 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1227 if (src
->intent
!= INTENT_UNKNOWN
1228 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1231 if (src
->access
!= ACCESS_UNKNOWN
1232 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1235 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1238 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1240 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1243 /* The subroutines that set these bits also cause flavors to be set,
1244 and that has already happened in the original, so don't let it
1249 dest
->intrinsic
= 1;
1258 /************** Component name management ************/
1260 /* Component names of a derived type form their own little namespaces
1261 that are separate from all other spaces. The space is composed of
1262 a singly linked list of gfc_component structures whose head is
1263 located in the parent symbol. */
1266 /* Add a component name to a symbol. The call fails if the name is
1267 already present. On success, the component pointer is modified to
1268 point to the additional component structure. */
1271 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1273 gfc_component
*p
, *tail
;
1277 for (p
= sym
->components
; p
; p
= p
->next
)
1279 if (strcmp (p
->name
, name
) == 0)
1281 gfc_error ("Component '%s' at %C already declared at %L",
1289 /* Allocate a new component. */
1290 p
= gfc_get_component ();
1293 sym
->components
= p
;
1297 p
->name
= gfc_get_string (name
);
1298 p
->loc
= gfc_current_locus
;
1305 /* Recursive function to switch derived types of all symbol in a
1309 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1317 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1318 sym
->ts
.derived
= to
;
1320 switch_types (st
->left
, from
, to
);
1321 switch_types (st
->right
, from
, to
);
1325 /* This subroutine is called when a derived type is used in order to
1326 make the final determination about which version to use. The
1327 standard requires that a type be defined before it is 'used', but
1328 such types can appear in IMPLICIT statements before the actual
1329 definition. 'Using' in this context means declaring a variable to
1330 be that type or using the type constructor.
1332 If a type is used and the components haven't been defined, then we
1333 have to have a derived type in a parent unit. We find the node in
1334 the other namespace and point the symtree node in this namespace to
1335 that node. Further reference to this name point to the correct
1336 node. If we can't find the node in a parent namespace, then we have
1339 This subroutine takes a pointer to a symbol node and returns a
1340 pointer to the translated node or NULL for an error. Usually there
1341 is no translation and we return the node we were passed. */
1344 gfc_use_derived (gfc_symbol
* sym
)
1351 if (sym
->components
!= NULL
)
1352 return sym
; /* Already defined. */
1354 if (sym
->ns
->parent
== NULL
)
1357 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1359 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1363 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1366 /* Get rid of symbol sym, translating all references to s. */
1367 for (i
= 0; i
< GFC_LETTERS
; i
++)
1369 t
= &sym
->ns
->default_type
[i
];
1370 if (t
->derived
== sym
)
1374 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1379 /* Unlink from list of modified symbols. */
1380 if (changed_syms
== sym
)
1381 changed_syms
= sym
->tlink
;
1383 for (p
= changed_syms
; p
; p
= p
->tlink
)
1384 if (p
->tlink
== sym
)
1386 p
->tlink
= sym
->tlink
;
1390 switch_types (sym
->ns
->sym_root
, sym
, s
);
1392 /* TODO: Also have to replace sym -> s in other lists like
1393 namelists, common lists and interface lists. */
1394 gfc_free_symbol (sym
);
1399 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1405 /* Given a derived type node and a component name, try to locate the
1406 component structure. Returns the NULL pointer if the component is
1407 not found or the components are private. */
1410 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1417 sym
= gfc_use_derived (sym
);
1422 for (p
= sym
->components
; p
; p
= p
->next
)
1423 if (strcmp (p
->name
, name
) == 0)
1427 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1431 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1433 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1443 /* Given a symbol, free all of the component structures and everything
1447 free_components (gfc_component
* p
)
1455 gfc_free_array_spec (p
->as
);
1456 gfc_free_expr (p
->initializer
);
1463 /* Set component attributes from a standard symbol attribute
1467 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1470 c
->dimension
= attr
->dimension
;
1471 c
->pointer
= attr
->pointer
;
1475 /* Get a standard symbol attribute structure given the component
1479 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1482 gfc_clear_attr (attr
);
1483 attr
->dimension
= c
->dimension
;
1484 attr
->pointer
= c
->pointer
;
1488 /******************** Statement label management ********************/
1490 /* Comparison function for statement labels, used for managing the
1494 compare_st_labels (void * a1
, void * b1
)
1496 int a
= ((gfc_st_label
*)a1
)->value
;
1497 int b
= ((gfc_st_label
*)b1
)->value
;
1503 /* Free a single gfc_st_label structure, making sure the tree is not
1504 messed up. This function is called only when some parse error
1508 gfc_free_st_label (gfc_st_label
* label
)
1513 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1515 if (label
->format
!= NULL
)
1516 gfc_free_expr (label
->format
);
1521 /* Free a whole tree of gfc_st_label structures. */
1524 free_st_labels (gfc_st_label
* label
)
1529 free_st_labels (label
->left
);
1530 free_st_labels (label
->right
);
1532 if (label
->format
!= NULL
)
1533 gfc_free_expr (label
->format
);
1538 /* Given a label number, search for and return a pointer to the label
1539 structure, creating it if it does not exist. */
1542 gfc_get_st_label (int labelno
)
1546 /* First see if the label is already in this namespace. */
1547 lp
= gfc_current_ns
->st_labels
;
1550 if (lp
->value
== labelno
)
1553 if (lp
->value
< labelno
)
1559 lp
= gfc_getmem (sizeof (gfc_st_label
));
1561 lp
->value
= labelno
;
1562 lp
->defined
= ST_LABEL_UNKNOWN
;
1563 lp
->referenced
= ST_LABEL_UNKNOWN
;
1565 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1571 /* Called when a statement with a statement label is about to be
1572 accepted. We add the label to the list of the current namespace,
1573 making sure it hasn't been defined previously and referenced
1577 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1581 labelno
= lp
->value
;
1583 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1584 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1585 &lp
->where
, label_locus
);
1588 lp
->where
= *label_locus
;
1592 case ST_LABEL_FORMAT
:
1593 if (lp
->referenced
== ST_LABEL_TARGET
)
1594 gfc_error ("Label %d at %C already referenced as branch target",
1597 lp
->defined
= ST_LABEL_FORMAT
;
1601 case ST_LABEL_TARGET
:
1602 if (lp
->referenced
== ST_LABEL_FORMAT
)
1603 gfc_error ("Label %d at %C already referenced as a format label",
1606 lp
->defined
= ST_LABEL_TARGET
;
1611 lp
->defined
= ST_LABEL_BAD_TARGET
;
1612 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1618 /* Reference a label. Given a label and its type, see if that
1619 reference is consistent with what is known about that label,
1620 updating the unknown state. Returns FAILURE if something goes
1624 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1626 gfc_sl_type label_type
;
1633 labelno
= lp
->value
;
1635 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1636 label_type
= lp
->defined
;
1639 label_type
= lp
->referenced
;
1640 lp
->where
= gfc_current_locus
;
1643 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1645 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1650 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1651 && type
== ST_LABEL_FORMAT
)
1653 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1658 lp
->referenced
= type
;
1666 /************** Symbol table management subroutines ****************/
1668 /* Basic details: Fortran 95 requires a potentially unlimited number
1669 of distinct namespaces when compiling a program unit. This case
1670 occurs during a compilation of internal subprograms because all of
1671 the internal subprograms must be read before we can start
1672 generating code for the host.
1674 Given the tricky nature of the Fortran grammar, we must be able to
1675 undo changes made to a symbol table if the current interpretation
1676 of a statement is found to be incorrect. Whenever a symbol is
1677 looked up, we make a copy of it and link to it. All of these
1678 symbols are kept in a singly linked list so that we can commit or
1679 undo the changes at a later time.
1681 A symtree may point to a symbol node outside of its namespace. In
1682 this case, that symbol has been used as a host associated variable
1683 at some previous time. */
1685 /* Allocate a new namespace structure. Copies the implicit types from
1686 PARENT if PARENT_TYPES is set. */
1689 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1693 gfc_intrinsic_op in
;
1696 ns
= gfc_getmem (sizeof (gfc_namespace
));
1697 ns
->sym_root
= NULL
;
1698 ns
->uop_root
= NULL
;
1699 ns
->default_access
= ACCESS_UNKNOWN
;
1700 ns
->parent
= parent
;
1702 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1703 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1705 /* Initialize default implicit types. */
1706 for (i
= 'a'; i
<= 'z'; i
++)
1708 ns
->set_flag
[i
- 'a'] = 0;
1709 ts
= &ns
->default_type
[i
- 'a'];
1711 if (parent_types
&& ns
->parent
!= NULL
)
1713 /* Copy parent settings */
1714 *ts
= ns
->parent
->default_type
[i
- 'a'];
1718 if (gfc_option
.flag_implicit_none
!= 0)
1724 if ('i' <= i
&& i
<= 'n')
1726 ts
->type
= BT_INTEGER
;
1727 ts
->kind
= gfc_default_integer_kind
;
1732 ts
->kind
= gfc_default_real_kind
;
1742 /* Comparison function for symtree nodes. */
1745 compare_symtree (void * _st1
, void * _st2
)
1747 gfc_symtree
*st1
, *st2
;
1749 st1
= (gfc_symtree
*) _st1
;
1750 st2
= (gfc_symtree
*) _st2
;
1752 return strcmp (st1
->name
, st2
->name
);
1756 /* Allocate a new symtree node and associate it with the new symbol. */
1759 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1763 st
= gfc_getmem (sizeof (gfc_symtree
));
1764 st
->name
= gfc_get_string (name
);
1766 gfc_insert_bbt (root
, st
, compare_symtree
);
1771 /* Delete a symbol from the tree. Does not free the symbol itself! */
1774 delete_symtree (gfc_symtree
** root
, const char *name
)
1776 gfc_symtree st
, *st0
;
1778 st0
= gfc_find_symtree (*root
, name
);
1780 st
.name
= gfc_get_string (name
);
1781 gfc_delete_bbt (root
, &st
, compare_symtree
);
1787 /* Given a root symtree node and a name, try to find the symbol within
1788 the namespace. Returns NULL if the symbol is not found. */
1791 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1797 c
= strcmp (name
, st
->name
);
1801 st
= (c
< 0) ? st
->left
: st
->right
;
1808 /* Given a name find a user operator node, creating it if it doesn't
1809 exist. These are much simpler than symbols because they can't be
1810 ambiguous with one another. */
1813 gfc_get_uop (const char *name
)
1818 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1822 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1824 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1825 uop
->name
= gfc_get_string (name
);
1826 uop
->access
= ACCESS_UNKNOWN
;
1827 uop
->ns
= gfc_current_ns
;
1833 /* Given a name find the user operator node. Returns NULL if it does
1837 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1842 ns
= gfc_current_ns
;
1844 st
= gfc_find_symtree (ns
->uop_root
, name
);
1845 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1849 /* Remove a gfc_symbol structure and everything it points to. */
1852 gfc_free_symbol (gfc_symbol
* sym
)
1858 gfc_free_array_spec (sym
->as
);
1860 free_components (sym
->components
);
1862 gfc_free_expr (sym
->value
);
1864 gfc_free_namelist (sym
->namelist
);
1866 gfc_free_namespace (sym
->formal_ns
);
1868 gfc_free_interface (sym
->generic
);
1870 gfc_free_formal_arglist (sym
->formal
);
1876 /* Allocate and initialize a new symbol node. */
1879 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1883 p
= gfc_getmem (sizeof (gfc_symbol
));
1885 gfc_clear_ts (&p
->ts
);
1886 gfc_clear_attr (&p
->attr
);
1889 p
->declared_at
= gfc_current_locus
;
1891 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1892 gfc_internal_error ("new_symbol(): Symbol name too long");
1894 p
->name
= gfc_get_string (name
);
1899 /* Generate an error if a symbol is ambiguous. */
1902 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1905 if (st
->n
.sym
->module
)
1906 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1907 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1909 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1910 "from current program unit", name
, st
->n
.sym
->name
);
1914 /* Search for a symtree starting in the current namespace, resorting to
1915 any parent namespaces if requested by a nonzero parent_flag.
1916 Returns nonzero if the name is ambiguous. */
1919 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1920 gfc_symtree
** result
)
1925 ns
= gfc_current_ns
;
1929 st
= gfc_find_symtree (ns
->sym_root
, name
);
1935 ambiguous_symbol (name
, st
);
1954 /* Same, but returns the symbol instead. */
1957 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1958 gfc_symbol
** result
)
1963 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1968 *result
= st
->n
.sym
;
1974 /* Save symbol with the information necessary to back it out. */
1977 save_symbol_data (gfc_symbol
* sym
)
1980 if (sym
->new || sym
->old_symbol
!= NULL
)
1983 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1984 *(sym
->old_symbol
) = *sym
;
1986 sym
->tlink
= changed_syms
;
1991 /* Given a name, find a symbol, or create it if it does not exist yet
1992 in the current namespace. If the symbol is found we make sure that
1995 The integer return code indicates
1997 1 The symbol name was ambiguous
1998 2 The name meant to be established was already host associated.
2000 So if the return value is nonzero, then an error was issued. */
2003 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2008 /* This doesn't usually happen during resolution. */
2010 ns
= gfc_current_ns
;
2012 /* Try to find the symbol in ns. */
2013 st
= gfc_find_symtree (ns
->sym_root
, name
);
2017 /* If not there, create a new symbol. */
2018 p
= gfc_new_symbol (name
, ns
);
2020 /* Add to the list of tentative symbols. */
2021 p
->old_symbol
= NULL
;
2022 p
->tlink
= changed_syms
;
2027 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2034 /* Make sure the existing symbol is OK. */
2037 ambiguous_symbol (name
, st
);
2043 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2045 /* Symbol is from another namespace. */
2046 gfc_error ("Symbol '%s' at %C has already been host associated",
2053 /* Copy in case this symbol is changed. */
2054 save_symbol_data (p
);
2063 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2069 i
= gfc_get_sym_tree (name
, ns
, &st
);
2074 *result
= st
->n
.sym
;
2081 /* Subroutine that searches for a symbol, creating it if it doesn't
2082 exist, but tries to host-associate the symbol if possible. */
2085 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2090 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2093 save_symbol_data (st
->n
.sym
);
2099 if (gfc_current_ns
->parent
!= NULL
)
2101 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2112 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2117 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2122 i
= gfc_get_ha_sym_tree (name
, &st
);
2125 *result
= st
->n
.sym
;
2132 /* Return true if both symbols could refer to the same data object. Does
2133 not take account of aliasing due to equivalence statements. */
2136 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2138 /* Aliasing isn't possible if the symbols have different base types. */
2139 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2142 /* Pointers can point to other pointers, target objects and allocatable
2143 objects. Two allocatable objects cannot share the same storage. */
2144 if (lsym
->attr
.pointer
2145 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2147 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2149 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2156 /* Undoes all the changes made to symbols in the current statement.
2157 This subroutine is made simpler due to the fact that attributes are
2158 never removed once added. */
2161 gfc_undo_symbols (void)
2163 gfc_symbol
*p
, *q
, *old
;
2165 for (p
= changed_syms
; p
; p
= q
)
2171 /* Symbol was new. */
2172 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2176 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2178 gfc_free_symbol (p
);
2182 /* Restore previous state of symbol. Just copy simple stuff. */
2184 old
= p
->old_symbol
;
2186 p
->ts
.type
= old
->ts
.type
;
2187 p
->ts
.kind
= old
->ts
.kind
;
2189 p
->attr
= old
->attr
;
2191 if (p
->value
!= old
->value
)
2193 gfc_free_expr (old
->value
);
2197 if (p
->as
!= old
->as
)
2200 gfc_free_array_spec (p
->as
);
2204 p
->generic
= old
->generic
;
2205 p
->component_access
= old
->component_access
;
2207 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2209 gfc_free_namelist (p
->namelist
);
2215 if (p
->namelist_tail
!= old
->namelist_tail
)
2217 gfc_free_namelist (old
->namelist_tail
);
2218 old
->namelist_tail
->next
= NULL
;
2222 p
->namelist_tail
= old
->namelist_tail
;
2224 if (p
->formal
!= old
->formal
)
2226 gfc_free_formal_arglist (p
->formal
);
2227 p
->formal
= old
->formal
;
2230 gfc_free (p
->old_symbol
);
2231 p
->old_symbol
= NULL
;
2235 changed_syms
= NULL
;
2239 /* Makes the changes made in the current statement permanent-- gets
2240 rid of undo information. */
2243 gfc_commit_symbols (void)
2247 for (p
= changed_syms
; p
; p
= q
)
2254 if (p
->old_symbol
!= NULL
)
2256 gfc_free (p
->old_symbol
);
2257 p
->old_symbol
= NULL
;
2261 changed_syms
= NULL
;
2265 /* Recursive function that deletes an entire tree and all the common
2266 head structures it points to. */
2269 free_common_tree (gfc_symtree
* common_tree
)
2271 if (common_tree
== NULL
)
2274 free_common_tree (common_tree
->left
);
2275 free_common_tree (common_tree
->right
);
2277 gfc_free (common_tree
);
2281 /* Recursive function that deletes an entire tree and all the user
2282 operator nodes that it contains. */
2285 free_uop_tree (gfc_symtree
* uop_tree
)
2288 if (uop_tree
== NULL
)
2291 free_uop_tree (uop_tree
->left
);
2292 free_uop_tree (uop_tree
->right
);
2294 gfc_free_interface (uop_tree
->n
.uop
->operator);
2296 gfc_free (uop_tree
->n
.uop
);
2297 gfc_free (uop_tree
);
2301 /* Recursive function that deletes an entire tree and all the symbols
2302 that it contains. */
2305 free_sym_tree (gfc_symtree
* sym_tree
)
2310 if (sym_tree
== NULL
)
2313 free_sym_tree (sym_tree
->left
);
2314 free_sym_tree (sym_tree
->right
);
2316 sym
= sym_tree
->n
.sym
;
2320 gfc_internal_error ("free_sym_tree(): Negative refs");
2322 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2324 /* As formal_ns contains a reference to sym, delete formal_ns just
2325 before the deletion of sym. */
2326 ns
= sym
->formal_ns
;
2327 sym
->formal_ns
= NULL
;
2328 gfc_free_namespace (ns
);
2330 else if (sym
->refs
== 0)
2332 /* Go ahead and delete the symbol. */
2333 gfc_free_symbol (sym
);
2336 gfc_free (sym_tree
);
2340 /* Free a derived type list. */
2343 gfc_free_dt_list (gfc_dt_list
* dt
)
2355 /* Free a namespace structure and everything below it. Interface
2356 lists associated with intrinsic operators are not freed. These are
2357 taken care of when a specific name is freed. */
2360 gfc_free_namespace (gfc_namespace
* ns
)
2362 gfc_charlen
*cl
, *cl2
;
2363 gfc_namespace
*p
, *q
;
2372 gcc_assert (ns
->refs
== 0);
2374 gfc_free_statements (ns
->code
);
2376 free_sym_tree (ns
->sym_root
);
2377 free_uop_tree (ns
->uop_root
);
2378 free_common_tree (ns
->common_root
);
2380 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2383 gfc_free_expr (cl
->length
);
2387 free_st_labels (ns
->st_labels
);
2389 gfc_free_equiv (ns
->equiv
);
2391 gfc_free_dt_list (ns
->derived_types
);
2393 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2394 gfc_free_interface (ns
->operator[i
]);
2396 gfc_free_data (ns
->data
);
2400 /* Recursively free any contained namespaces. */
2406 gfc_free_namespace (q
);
2412 gfc_symbol_init_2 (void)
2415 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2420 gfc_symbol_done_2 (void)
2423 gfc_free_namespace (gfc_current_ns
);
2424 gfc_current_ns
= NULL
;
2428 /* Clear mark bits from symbol nodes associated with a symtree node. */
2431 clear_sym_mark (gfc_symtree
* st
)
2434 st
->n
.sym
->mark
= 0;
2438 /* Recursively traverse the symtree nodes. */
2441 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2447 gfc_traverse_symtree (st
->left
, func
);
2448 gfc_traverse_symtree (st
->right
, func
);
2453 /* Recursive namespace traversal function. */
2456 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2462 if (st
->n
.sym
->mark
== 0)
2463 (*func
) (st
->n
.sym
);
2464 st
->n
.sym
->mark
= 1;
2466 traverse_ns (st
->left
, func
);
2467 traverse_ns (st
->right
, func
);
2471 /* Call a given function for all symbols in the namespace. We take
2472 care that each gfc_symbol node is called exactly once. */
2475 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2478 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2480 traverse_ns (ns
->sym_root
, func
);
2484 /* Return TRUE if the symbol is an automatic variable. */
2486 gfc_is_var_automatic (gfc_symbol
* sym
)
2488 /* Pointer and allocatable variables are never automatic. */
2489 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2491 /* Check for arrays with non-constant size. */
2492 if (sym
->attr
.dimension
&& sym
->as
2493 && !gfc_is_compile_time_shape (sym
->as
))
2495 /* Check for non-constant length character variables. */
2496 if (sym
->ts
.type
== BT_CHARACTER
2498 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2503 /* Given a symbol, mark it as SAVEd if it is allowed. */
2506 save_symbol (gfc_symbol
* sym
)
2509 if (sym
->attr
.use_assoc
)
2512 if (sym
->attr
.in_common
2514 || sym
->attr
.flavor
!= FL_VARIABLE
)
2516 /* Automatic objects are not saved. */
2517 if (gfc_is_var_automatic (sym
))
2519 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2523 /* Mark those symbols which can be SAVEd as such. */
2526 gfc_save_all (gfc_namespace
* ns
)
2529 gfc_traverse_ns (ns
, save_symbol
);
2534 /* Make sure that no changes to symbols are pending. */
2537 gfc_symbol_state(void) {
2539 if (changed_syms
!= NULL
)
2540 gfc_internal_error("Symbol changes still pending!");
2545 /************** Global symbol handling ************/
2548 /* Search a tree for the global symbol. */
2551 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2557 if (strcmp (symbol
->name
, name
) == 0)
2560 s
= gfc_find_gsymbol (symbol
->left
, name
);
2564 s
= gfc_find_gsymbol (symbol
->right
, name
);
2572 /* Compare two global symbols. Used for managing the BB tree. */
2575 gsym_compare (void * _s1
, void * _s2
)
2577 gfc_gsymbol
*s1
, *s2
;
2579 s1
= (gfc_gsymbol
*)_s1
;
2580 s2
= (gfc_gsymbol
*)_s2
;
2581 return strcmp(s1
->name
, s2
->name
);
2585 /* Get a global symbol, creating it if it doesn't exist. */
2588 gfc_get_gsymbol (const char *name
)
2592 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2596 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2597 s
->type
= GSYM_UNKNOWN
;
2598 s
->name
= gfc_get_string (name
);
2600 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);