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";
268 static const char *threadprivate
= "THREADPRIVATE";
273 where
= &gfc_current_locus
;
275 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
282 /* Check for attributes not allowed in a BLOCK DATA. */
283 if (gfc_current_state () == COMP_BLOCK_DATA
)
287 if (attr
->in_namelist
)
289 if (attr
->allocatable
)
295 if (attr
->access
== ACCESS_PRIVATE
)
297 if (attr
->access
== ACCESS_PUBLIC
)
299 if (attr
->intent
!= INTENT_UNKNOWN
)
305 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
312 conf (dummy
, threadprivate
);
313 conf (pointer
, target
);
314 conf (pointer
, external
);
315 conf (pointer
, intrinsic
);
316 conf (pointer
, elemental
);
318 conf (target
, external
);
319 conf (target
, intrinsic
);
320 conf (external
, dimension
); /* See Fortran 95's R504. */
322 conf (external
, intrinsic
);
324 if (attr
->if_source
|| attr
->contained
)
326 conf (external
, subroutine
);
327 conf (external
, function
);
330 conf (allocatable
, pointer
);
331 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
332 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
333 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
334 conf (elemental
, recursive
);
336 conf (in_common
, dummy
);
337 conf (in_common
, allocatable
);
338 conf (in_common
, result
);
339 conf (in_common
, save
);
342 conf (dummy
, result
);
344 conf (in_equivalence
, use_assoc
);
345 conf (in_equivalence
, dummy
);
346 conf (in_equivalence
, target
);
347 conf (in_equivalence
, pointer
);
348 conf (in_equivalence
, function
);
349 conf (in_equivalence
, result
);
350 conf (in_equivalence
, entry
);
351 conf (in_equivalence
, allocatable
);
352 conf (in_equivalence
, threadprivate
);
354 conf (in_namelist
, pointer
);
355 conf (in_namelist
, allocatable
);
357 conf (entry
, result
);
359 conf (function
, subroutine
);
361 /* Cray pointer/pointee conflicts. */
362 conf (cray_pointer
, cray_pointee
);
363 conf (cray_pointer
, dimension
);
364 conf (cray_pointer
, pointer
);
365 conf (cray_pointer
, target
);
366 conf (cray_pointer
, allocatable
);
367 conf (cray_pointer
, external
);
368 conf (cray_pointer
, intrinsic
);
369 conf (cray_pointer
, in_namelist
);
370 conf (cray_pointer
, function
);
371 conf (cray_pointer
, subroutine
);
372 conf (cray_pointer
, entry
);
374 conf (cray_pointee
, allocatable
);
375 conf (cray_pointee
, intent
);
376 conf (cray_pointee
, optional
);
377 conf (cray_pointee
, dummy
);
378 conf (cray_pointee
, target
);
379 conf (cray_pointee
, external
);
380 conf (cray_pointee
, intrinsic
);
381 conf (cray_pointee
, pointer
);
382 conf (cray_pointee
, function
);
383 conf (cray_pointee
, subroutine
);
384 conf (cray_pointee
, entry
);
385 conf (cray_pointee
, in_common
);
386 conf (cray_pointee
, in_equivalence
);
387 conf (cray_pointee
, threadprivate
);
390 conf (data
, function
);
392 conf (data
, allocatable
);
393 conf (data
, use_assoc
);
395 a1
= gfc_code2string (flavors
, attr
->flavor
);
397 if (attr
->in_namelist
398 && attr
->flavor
!= FL_VARIABLE
399 && attr
->flavor
!= FL_UNKNOWN
)
406 switch (attr
->flavor
)
424 conf2 (threadprivate
);
434 if (attr
->subroutine
)
443 conf2(threadprivate
);
448 case PROC_ST_FUNCTION
:
461 conf2 (threadprivate
);
482 conf2 (threadprivate
);
484 if (attr
->intent
!= INTENT_UNKNOWN
)
504 conf2 (threadprivate
);
515 gfc_error ("%s attribute conflicts with %s attribute at %L",
518 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
519 a1
, a2
, name
, where
);
528 /* Mark a symbol as referenced. */
531 gfc_set_sym_referenced (gfc_symbol
* sym
)
533 if (sym
->attr
.referenced
)
536 sym
->attr
.referenced
= 1;
538 /* Remember which order dummy variables are accessed in. */
540 sym
->dummy_order
= next_dummy_order
++;
544 /* Common subroutine called by attribute changing subroutines in order
545 to prevent them from changing a symbol that has been
546 use-associated. Returns zero if it is OK to change the symbol,
550 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
553 if (attr
->use_assoc
== 0)
557 where
= &gfc_current_locus
;
560 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
563 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
570 /* Used to prevent changing the attributes of a symbol after it has been
571 used. This check is only done for dummy variables as only these can be
572 used in specification expressions. Applying this to all symbols causes
573 an error when we reach the body of a contained function. */
576 check_done (symbol_attribute
* attr
, locus
* where
)
579 if (!(attr
->dummy
&& attr
->referenced
))
583 where
= &gfc_current_locus
;
585 gfc_error ("Cannot change attributes of symbol at %L"
586 " after it has been used", where
);
592 /* Generate an error because of a duplicate attribute. */
595 duplicate_attr (const char *attr
, locus
* where
)
599 where
= &gfc_current_locus
;
601 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
604 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
607 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
,
608 unsigned int attr_intent
)
611 if (check_used (attr
, NULL
, where
)
612 || (attr_intent
== 0 && check_done (attr
, where
)))
615 return check_conflict (attr
, NULL
, where
);
619 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
622 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
625 if (attr
->allocatable
)
627 duplicate_attr ("ALLOCATABLE", where
);
631 attr
->allocatable
= 1;
632 return check_conflict (attr
, NULL
, where
);
637 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
640 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
645 duplicate_attr ("DIMENSION", where
);
650 return check_conflict (attr
, name
, where
);
655 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
658 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
663 duplicate_attr ("EXTERNAL", where
);
669 return check_conflict (attr
, NULL
, where
);
674 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
677 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
682 duplicate_attr ("INTRINSIC", where
);
688 return check_conflict (attr
, NULL
, where
);
693 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
696 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
701 duplicate_attr ("OPTIONAL", where
);
706 return check_conflict (attr
, NULL
, where
);
711 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
714 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
718 return check_conflict (attr
, NULL
, where
);
723 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
726 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
729 attr
->cray_pointer
= 1;
730 return check_conflict (attr
, NULL
, where
);
735 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
738 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
741 if (attr
->cray_pointee
)
743 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
744 " statements.", where
);
748 attr
->cray_pointee
= 1;
749 return check_conflict (attr
, NULL
, where
);
754 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
757 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
761 return check_conflict (attr
, name
, where
);
766 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
769 if (check_used (attr
, name
, where
))
775 ("SAVE attribute at %L cannot be specified in a PURE procedure",
782 if (gfc_notify_std (GFC_STD_LEGACY
,
783 "Duplicate SAVE attribute specified at %L",
790 return check_conflict (attr
, name
, where
);
795 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
797 if (check_used (attr
, name
, where
))
800 if (attr
->threadprivate
)
802 duplicate_attr ("THREADPRIVATE", where
);
806 attr
->threadprivate
= 1;
807 return check_conflict (attr
, name
, where
);
812 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
815 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
820 duplicate_attr ("TARGET", where
);
825 return check_conflict (attr
, NULL
, where
);
830 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
833 if (check_used (attr
, name
, where
))
836 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
838 return check_conflict (attr
, name
, where
);
843 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
846 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
849 /* Duplicate attribute already checked for. */
851 if (check_conflict (attr
, name
, where
) == FAILURE
)
854 if (attr
->flavor
== FL_VARIABLE
)
857 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
861 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
864 /* Duplicate attribute already checked for. */
865 attr
->in_equivalence
= 1;
866 if (check_conflict (attr
, name
, where
) == FAILURE
)
869 if (attr
->flavor
== FL_VARIABLE
)
872 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
877 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
880 if (check_used (attr
, name
, where
))
884 return check_conflict (attr
, name
, where
);
889 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
893 attr
->in_namelist
= 1;
894 return check_conflict (attr
, name
, where
);
899 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
902 if (check_used (attr
, name
, where
))
906 return check_conflict (attr
, name
, where
);
911 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
914 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
918 return check_conflict (attr
, NULL
, where
);
923 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
926 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
930 return check_conflict (attr
, NULL
, where
);
935 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
938 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
942 return check_conflict (attr
, NULL
, where
);
947 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
950 if (check_used (attr
, name
, where
))
955 duplicate_attr ("ENTRY", where
);
960 return check_conflict (attr
, name
, where
);
965 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
968 if (attr
->flavor
!= FL_PROCEDURE
969 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
973 return check_conflict (attr
, name
, where
);
978 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
981 if (attr
->flavor
!= FL_PROCEDURE
982 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
985 attr
->subroutine
= 1;
986 return check_conflict (attr
, name
, where
);
991 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
994 if (attr
->flavor
!= FL_PROCEDURE
995 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
999 return check_conflict (attr
, name
, where
);
1003 /* Flavors are special because some flavors are not what Fortran
1004 considers attributes and can be reaffirmed multiple times. */
1007 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1011 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1012 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1013 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1016 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1019 if (attr
->flavor
!= FL_UNKNOWN
)
1022 where
= &gfc_current_locus
;
1024 gfc_error ("%s attribute conflicts with %s attribute at %L",
1025 gfc_code2string (flavors
, attr
->flavor
),
1026 gfc_code2string (flavors
, f
), where
);
1033 return check_conflict (attr
, name
, where
);
1038 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1039 const char *name
, locus
* where
)
1042 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1045 if (attr
->flavor
!= FL_PROCEDURE
1046 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1050 where
= &gfc_current_locus
;
1052 if (attr
->proc
!= PROC_UNKNOWN
)
1054 gfc_error ("%s procedure at %L is already declared as %s procedure",
1055 gfc_code2string (procedures
, t
), where
,
1056 gfc_code2string (procedures
, attr
->proc
));
1063 /* Statement functions are always scalar and functions. */
1064 if (t
== PROC_ST_FUNCTION
1065 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1066 || attr
->dimension
))
1069 return check_conflict (attr
, name
, where
);
1074 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1077 if (check_used (attr
, NULL
, where
))
1080 if (attr
->intent
== INTENT_UNKNOWN
)
1082 attr
->intent
= intent
;
1083 return check_conflict (attr
, NULL
, where
);
1087 where
= &gfc_current_locus
;
1089 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1090 gfc_intent_string (attr
->intent
),
1091 gfc_intent_string (intent
), where
);
1097 /* No checks for use-association in public and private statements. */
1100 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1101 const char *name
, locus
* where
)
1104 if (attr
->access
== ACCESS_UNKNOWN
)
1106 attr
->access
= access
;
1107 return check_conflict (attr
, name
, where
);
1111 where
= &gfc_current_locus
;
1112 gfc_error ("ACCESS specification at %L was already specified", where
);
1119 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1120 gfc_formal_arglist
* formal
, locus
* where
)
1123 if (check_used (&sym
->attr
, sym
->name
, where
))
1127 where
= &gfc_current_locus
;
1129 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1130 && sym
->attr
.if_source
!= IFSRC_DECL
)
1132 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1137 sym
->formal
= formal
;
1138 sym
->attr
.if_source
= source
;
1144 /* Add a type to a symbol. */
1147 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1151 /* TODO: This is legal if it is reaffirming an implicit type.
1152 if (check_done (&sym->attr, where))
1156 where
= &gfc_current_locus
;
1158 if (sym
->ts
.type
!= BT_UNKNOWN
)
1160 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1161 where
, gfc_basic_typename (sym
->ts
.type
));
1165 flavor
= sym
->attr
.flavor
;
1167 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1168 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1169 && sym
->attr
.subroutine
)
1170 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1172 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1181 /* Clears all attributes. */
1184 gfc_clear_attr (symbol_attribute
* attr
)
1186 memset (attr
, 0, sizeof(symbol_attribute
));
1190 /* Check for missing attributes in the new symbol. Currently does
1191 nothing, but it's not clear that it is unnecessary yet. */
1194 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1195 locus
* where ATTRIBUTE_UNUSED
)
1202 /* Copy an attribute to a symbol attribute, bit by bit. Some
1203 attributes have a lot of side-effects but cannot be present given
1204 where we are called from, so we ignore some bits. */
1207 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1210 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1213 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1215 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1217 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1219 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1221 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1223 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1225 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1227 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1232 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1235 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1238 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1240 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1242 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1245 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1247 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1249 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1251 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1254 if (src
->flavor
!= FL_UNKNOWN
1255 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1258 if (src
->intent
!= INTENT_UNKNOWN
1259 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1262 if (src
->access
!= ACCESS_UNKNOWN
1263 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1266 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1269 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1271 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1274 /* The subroutines that set these bits also cause flavors to be set,
1275 and that has already happened in the original, so don't let it
1280 dest
->intrinsic
= 1;
1289 /************** Component name management ************/
1291 /* Component names of a derived type form their own little namespaces
1292 that are separate from all other spaces. The space is composed of
1293 a singly linked list of gfc_component structures whose head is
1294 located in the parent symbol. */
1297 /* Add a component name to a symbol. The call fails if the name is
1298 already present. On success, the component pointer is modified to
1299 point to the additional component structure. */
1302 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1304 gfc_component
*p
, *tail
;
1308 for (p
= sym
->components
; p
; p
= p
->next
)
1310 if (strcmp (p
->name
, name
) == 0)
1312 gfc_error ("Component '%s' at %C already declared at %L",
1320 /* Allocate a new component. */
1321 p
= gfc_get_component ();
1324 sym
->components
= p
;
1328 p
->name
= gfc_get_string (name
);
1329 p
->loc
= gfc_current_locus
;
1336 /* Recursive function to switch derived types of all symbol in a
1340 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1348 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1349 sym
->ts
.derived
= to
;
1351 switch_types (st
->left
, from
, to
);
1352 switch_types (st
->right
, from
, to
);
1356 /* This subroutine is called when a derived type is used in order to
1357 make the final determination about which version to use. The
1358 standard requires that a type be defined before it is 'used', but
1359 such types can appear in IMPLICIT statements before the actual
1360 definition. 'Using' in this context means declaring a variable to
1361 be that type or using the type constructor.
1363 If a type is used and the components haven't been defined, then we
1364 have to have a derived type in a parent unit. We find the node in
1365 the other namespace and point the symtree node in this namespace to
1366 that node. Further reference to this name point to the correct
1367 node. If we can't find the node in a parent namespace, then we have
1370 This subroutine takes a pointer to a symbol node and returns a
1371 pointer to the translated node or NULL for an error. Usually there
1372 is no translation and we return the node we were passed. */
1375 gfc_use_derived (gfc_symbol
* sym
)
1382 if (sym
->components
!= NULL
)
1383 return sym
; /* Already defined. */
1385 if (sym
->ns
->parent
== NULL
)
1388 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1390 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1394 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1397 /* Get rid of symbol sym, translating all references to s. */
1398 for (i
= 0; i
< GFC_LETTERS
; i
++)
1400 t
= &sym
->ns
->default_type
[i
];
1401 if (t
->derived
== sym
)
1405 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1410 /* Unlink from list of modified symbols. */
1411 gfc_commit_symbol (sym
);
1413 switch_types (sym
->ns
->sym_root
, sym
, s
);
1415 /* TODO: Also have to replace sym -> s in other lists like
1416 namelists, common lists and interface lists. */
1417 gfc_free_symbol (sym
);
1422 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1428 /* Given a derived type node and a component name, try to locate the
1429 component structure. Returns the NULL pointer if the component is
1430 not found or the components are private. */
1433 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1440 sym
= gfc_use_derived (sym
);
1445 for (p
= sym
->components
; p
; p
= p
->next
)
1446 if (strcmp (p
->name
, name
) == 0)
1450 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1454 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1456 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1466 /* Given a symbol, free all of the component structures and everything
1470 free_components (gfc_component
* p
)
1478 gfc_free_array_spec (p
->as
);
1479 gfc_free_expr (p
->initializer
);
1486 /* Set component attributes from a standard symbol attribute
1490 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1493 c
->dimension
= attr
->dimension
;
1494 c
->pointer
= attr
->pointer
;
1498 /* Get a standard symbol attribute structure given the component
1502 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1505 gfc_clear_attr (attr
);
1506 attr
->dimension
= c
->dimension
;
1507 attr
->pointer
= c
->pointer
;
1511 /******************** Statement label management ********************/
1513 /* Comparison function for statement labels, used for managing the
1517 compare_st_labels (void * a1
, void * b1
)
1519 int a
= ((gfc_st_label
*)a1
)->value
;
1520 int b
= ((gfc_st_label
*)b1
)->value
;
1526 /* Free a single gfc_st_label structure, making sure the tree is not
1527 messed up. This function is called only when some parse error
1531 gfc_free_st_label (gfc_st_label
* label
)
1536 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1538 if (label
->format
!= NULL
)
1539 gfc_free_expr (label
->format
);
1544 /* Free a whole tree of gfc_st_label structures. */
1547 free_st_labels (gfc_st_label
* label
)
1552 free_st_labels (label
->left
);
1553 free_st_labels (label
->right
);
1555 if (label
->format
!= NULL
)
1556 gfc_free_expr (label
->format
);
1561 /* Given a label number, search for and return a pointer to the label
1562 structure, creating it if it does not exist. */
1565 gfc_get_st_label (int labelno
)
1569 /* First see if the label is already in this namespace. */
1570 lp
= gfc_current_ns
->st_labels
;
1573 if (lp
->value
== labelno
)
1576 if (lp
->value
< labelno
)
1582 lp
= gfc_getmem (sizeof (gfc_st_label
));
1584 lp
->value
= labelno
;
1585 lp
->defined
= ST_LABEL_UNKNOWN
;
1586 lp
->referenced
= ST_LABEL_UNKNOWN
;
1588 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1594 /* Called when a statement with a statement label is about to be
1595 accepted. We add the label to the list of the current namespace,
1596 making sure it hasn't been defined previously and referenced
1600 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1604 labelno
= lp
->value
;
1606 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1607 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1608 &lp
->where
, label_locus
);
1611 lp
->where
= *label_locus
;
1615 case ST_LABEL_FORMAT
:
1616 if (lp
->referenced
== ST_LABEL_TARGET
)
1617 gfc_error ("Label %d at %C already referenced as branch target",
1620 lp
->defined
= ST_LABEL_FORMAT
;
1624 case ST_LABEL_TARGET
:
1625 if (lp
->referenced
== ST_LABEL_FORMAT
)
1626 gfc_error ("Label %d at %C already referenced as a format label",
1629 lp
->defined
= ST_LABEL_TARGET
;
1634 lp
->defined
= ST_LABEL_BAD_TARGET
;
1635 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1641 /* Reference a label. Given a label and its type, see if that
1642 reference is consistent with what is known about that label,
1643 updating the unknown state. Returns FAILURE if something goes
1647 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1649 gfc_sl_type label_type
;
1656 labelno
= lp
->value
;
1658 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1659 label_type
= lp
->defined
;
1662 label_type
= lp
->referenced
;
1663 lp
->where
= gfc_current_locus
;
1666 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1668 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1673 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1674 && type
== ST_LABEL_FORMAT
)
1676 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1681 lp
->referenced
= type
;
1689 /************** Symbol table management subroutines ****************/
1691 /* Basic details: Fortran 95 requires a potentially unlimited number
1692 of distinct namespaces when compiling a program unit. This case
1693 occurs during a compilation of internal subprograms because all of
1694 the internal subprograms must be read before we can start
1695 generating code for the host.
1697 Given the tricky nature of the Fortran grammar, we must be able to
1698 undo changes made to a symbol table if the current interpretation
1699 of a statement is found to be incorrect. Whenever a symbol is
1700 looked up, we make a copy of it and link to it. All of these
1701 symbols are kept in a singly linked list so that we can commit or
1702 undo the changes at a later time.
1704 A symtree may point to a symbol node outside of its namespace. In
1705 this case, that symbol has been used as a host associated variable
1706 at some previous time. */
1708 /* Allocate a new namespace structure. Copies the implicit types from
1709 PARENT if PARENT_TYPES is set. */
1712 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1716 gfc_intrinsic_op in
;
1719 ns
= gfc_getmem (sizeof (gfc_namespace
));
1720 ns
->sym_root
= NULL
;
1721 ns
->uop_root
= NULL
;
1722 ns
->default_access
= ACCESS_UNKNOWN
;
1723 ns
->parent
= parent
;
1725 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1726 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1728 /* Initialize default implicit types. */
1729 for (i
= 'a'; i
<= 'z'; i
++)
1731 ns
->set_flag
[i
- 'a'] = 0;
1732 ts
= &ns
->default_type
[i
- 'a'];
1734 if (parent_types
&& ns
->parent
!= NULL
)
1736 /* Copy parent settings */
1737 *ts
= ns
->parent
->default_type
[i
- 'a'];
1741 if (gfc_option
.flag_implicit_none
!= 0)
1747 if ('i' <= i
&& i
<= 'n')
1749 ts
->type
= BT_INTEGER
;
1750 ts
->kind
= gfc_default_integer_kind
;
1755 ts
->kind
= gfc_default_real_kind
;
1765 /* Comparison function for symtree nodes. */
1768 compare_symtree (void * _st1
, void * _st2
)
1770 gfc_symtree
*st1
, *st2
;
1772 st1
= (gfc_symtree
*) _st1
;
1773 st2
= (gfc_symtree
*) _st2
;
1775 return strcmp (st1
->name
, st2
->name
);
1779 /* Allocate a new symtree node and associate it with the new symbol. */
1782 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1786 st
= gfc_getmem (sizeof (gfc_symtree
));
1787 st
->name
= gfc_get_string (name
);
1789 gfc_insert_bbt (root
, st
, compare_symtree
);
1794 /* Delete a symbol from the tree. Does not free the symbol itself! */
1797 delete_symtree (gfc_symtree
** root
, const char *name
)
1799 gfc_symtree st
, *st0
;
1801 st0
= gfc_find_symtree (*root
, name
);
1803 st
.name
= gfc_get_string (name
);
1804 gfc_delete_bbt (root
, &st
, compare_symtree
);
1810 /* Given a root symtree node and a name, try to find the symbol within
1811 the namespace. Returns NULL if the symbol is not found. */
1814 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1820 c
= strcmp (name
, st
->name
);
1824 st
= (c
< 0) ? st
->left
: st
->right
;
1831 /* Given a name find a user operator node, creating it if it doesn't
1832 exist. These are much simpler than symbols because they can't be
1833 ambiguous with one another. */
1836 gfc_get_uop (const char *name
)
1841 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1845 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1847 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1848 uop
->name
= gfc_get_string (name
);
1849 uop
->access
= ACCESS_UNKNOWN
;
1850 uop
->ns
= gfc_current_ns
;
1856 /* Given a name find the user operator node. Returns NULL if it does
1860 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1865 ns
= gfc_current_ns
;
1867 st
= gfc_find_symtree (ns
->uop_root
, name
);
1868 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1872 /* Remove a gfc_symbol structure and everything it points to. */
1875 gfc_free_symbol (gfc_symbol
* sym
)
1881 gfc_free_array_spec (sym
->as
);
1883 free_components (sym
->components
);
1885 gfc_free_expr (sym
->value
);
1887 gfc_free_namelist (sym
->namelist
);
1889 gfc_free_namespace (sym
->formal_ns
);
1891 gfc_free_interface (sym
->generic
);
1893 gfc_free_formal_arglist (sym
->formal
);
1899 /* Allocate and initialize a new symbol node. */
1902 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1906 p
= gfc_getmem (sizeof (gfc_symbol
));
1908 gfc_clear_ts (&p
->ts
);
1909 gfc_clear_attr (&p
->attr
);
1912 p
->declared_at
= gfc_current_locus
;
1914 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1915 gfc_internal_error ("new_symbol(): Symbol name too long");
1917 p
->name
= gfc_get_string (name
);
1922 /* Generate an error if a symbol is ambiguous. */
1925 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1928 if (st
->n
.sym
->module
)
1929 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1930 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1932 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1933 "from current program unit", name
, st
->n
.sym
->name
);
1937 /* Search for a symtree starting in the current namespace, resorting to
1938 any parent namespaces if requested by a nonzero parent_flag.
1939 Returns nonzero if the name is ambiguous. */
1942 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1943 gfc_symtree
** result
)
1948 ns
= gfc_current_ns
;
1952 st
= gfc_find_symtree (ns
->sym_root
, name
);
1958 ambiguous_symbol (name
, st
);
1977 /* Same, but returns the symbol instead. */
1980 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1981 gfc_symbol
** result
)
1986 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1991 *result
= st
->n
.sym
;
1997 /* Save symbol with the information necessary to back it out. */
2000 save_symbol_data (gfc_symbol
* sym
)
2003 if (sym
->new || sym
->old_symbol
!= NULL
)
2006 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2007 *(sym
->old_symbol
) = *sym
;
2009 sym
->tlink
= changed_syms
;
2014 /* Given a name, find a symbol, or create it if it does not exist yet
2015 in the current namespace. If the symbol is found we make sure that
2018 The integer return code indicates
2020 1 The symbol name was ambiguous
2021 2 The name meant to be established was already host associated.
2023 So if the return value is nonzero, then an error was issued. */
2026 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2031 /* This doesn't usually happen during resolution. */
2033 ns
= gfc_current_ns
;
2035 /* Try to find the symbol in ns. */
2036 st
= gfc_find_symtree (ns
->sym_root
, name
);
2040 /* If not there, create a new symbol. */
2041 p
= gfc_new_symbol (name
, ns
);
2043 /* Add to the list of tentative symbols. */
2044 p
->old_symbol
= NULL
;
2045 p
->tlink
= changed_syms
;
2050 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2057 /* Make sure the existing symbol is OK. */
2060 ambiguous_symbol (name
, st
);
2066 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2068 /* Symbol is from another namespace. */
2069 gfc_error ("Symbol '%s' at %C has already been host associated",
2076 /* Copy in case this symbol is changed. */
2077 save_symbol_data (p
);
2086 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2092 i
= gfc_get_sym_tree (name
, ns
, &st
);
2097 *result
= st
->n
.sym
;
2104 /* Subroutine that searches for a symbol, creating it if it doesn't
2105 exist, but tries to host-associate the symbol if possible. */
2108 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2113 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2116 save_symbol_data (st
->n
.sym
);
2122 if (gfc_current_ns
->parent
!= NULL
)
2124 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2135 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2140 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2145 i
= gfc_get_ha_sym_tree (name
, &st
);
2148 *result
= st
->n
.sym
;
2155 /* Return true if both symbols could refer to the same data object. Does
2156 not take account of aliasing due to equivalence statements. */
2159 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2161 /* Aliasing isn't possible if the symbols have different base types. */
2162 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2165 /* Pointers can point to other pointers, target objects and allocatable
2166 objects. Two allocatable objects cannot share the same storage. */
2167 if (lsym
->attr
.pointer
2168 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2170 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2172 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2179 /* Undoes all the changes made to symbols in the current statement.
2180 This subroutine is made simpler due to the fact that attributes are
2181 never removed once added. */
2184 gfc_undo_symbols (void)
2186 gfc_symbol
*p
, *q
, *old
;
2188 for (p
= changed_syms
; p
; p
= q
)
2194 /* Symbol was new. */
2195 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2199 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2201 gfc_free_symbol (p
);
2205 /* Restore previous state of symbol. Just copy simple stuff. */
2207 old
= p
->old_symbol
;
2209 p
->ts
.type
= old
->ts
.type
;
2210 p
->ts
.kind
= old
->ts
.kind
;
2212 p
->attr
= old
->attr
;
2214 if (p
->value
!= old
->value
)
2216 gfc_free_expr (old
->value
);
2220 if (p
->as
!= old
->as
)
2223 gfc_free_array_spec (p
->as
);
2227 p
->generic
= old
->generic
;
2228 p
->component_access
= old
->component_access
;
2230 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2232 gfc_free_namelist (p
->namelist
);
2238 if (p
->namelist_tail
!= old
->namelist_tail
)
2240 gfc_free_namelist (old
->namelist_tail
);
2241 old
->namelist_tail
->next
= NULL
;
2245 p
->namelist_tail
= old
->namelist_tail
;
2247 if (p
->formal
!= old
->formal
)
2249 gfc_free_formal_arglist (p
->formal
);
2250 p
->formal
= old
->formal
;
2253 gfc_free (p
->old_symbol
);
2254 p
->old_symbol
= NULL
;
2258 changed_syms
= NULL
;
2262 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2263 components of old_symbol that might need deallocation are the "allocatables"
2264 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2265 namelist_tail. In case these differ between old_symbol and sym, it's just
2266 because sym->namelist has gotten a few more items. */
2269 free_old_symbol (gfc_symbol
* sym
)
2271 if (sym
->old_symbol
== NULL
)
2274 if (sym
->old_symbol
->as
!= sym
->as
)
2275 gfc_free_array_spec (sym
->old_symbol
->as
);
2277 if (sym
->old_symbol
->value
!= sym
->value
)
2278 gfc_free_expr (sym
->old_symbol
->value
);
2280 if (sym
->old_symbol
->formal
!= sym
->formal
)
2281 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2283 gfc_free (sym
->old_symbol
);
2284 sym
->old_symbol
= NULL
;
2288 /* Makes the changes made in the current statement permanent-- gets
2289 rid of undo information. */
2292 gfc_commit_symbols (void)
2296 for (p
= changed_syms
; p
; p
= q
)
2303 free_old_symbol (p
);
2305 changed_syms
= NULL
;
2309 /* Makes the changes made in one symbol permanent -- gets rid of undo
2313 gfc_commit_symbol (gfc_symbol
* sym
)
2317 if (changed_syms
== sym
)
2318 changed_syms
= sym
->tlink
;
2321 for (p
= changed_syms
; p
; p
= p
->tlink
)
2322 if (p
->tlink
== sym
)
2324 p
->tlink
= sym
->tlink
;
2333 free_old_symbol (sym
);
2337 /* Recursive function that deletes an entire tree and all the common
2338 head structures it points to. */
2341 free_common_tree (gfc_symtree
* common_tree
)
2343 if (common_tree
== NULL
)
2346 free_common_tree (common_tree
->left
);
2347 free_common_tree (common_tree
->right
);
2349 gfc_free (common_tree
);
2353 /* Recursive function that deletes an entire tree and all the user
2354 operator nodes that it contains. */
2357 free_uop_tree (gfc_symtree
* uop_tree
)
2360 if (uop_tree
== NULL
)
2363 free_uop_tree (uop_tree
->left
);
2364 free_uop_tree (uop_tree
->right
);
2366 gfc_free_interface (uop_tree
->n
.uop
->operator);
2368 gfc_free (uop_tree
->n
.uop
);
2369 gfc_free (uop_tree
);
2373 /* Recursive function that deletes an entire tree and all the symbols
2374 that it contains. */
2377 free_sym_tree (gfc_symtree
* sym_tree
)
2382 if (sym_tree
== NULL
)
2385 free_sym_tree (sym_tree
->left
);
2386 free_sym_tree (sym_tree
->right
);
2388 sym
= sym_tree
->n
.sym
;
2392 gfc_internal_error ("free_sym_tree(): Negative refs");
2394 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2396 /* As formal_ns contains a reference to sym, delete formal_ns just
2397 before the deletion of sym. */
2398 ns
= sym
->formal_ns
;
2399 sym
->formal_ns
= NULL
;
2400 gfc_free_namespace (ns
);
2402 else if (sym
->refs
== 0)
2404 /* Go ahead and delete the symbol. */
2405 gfc_free_symbol (sym
);
2408 gfc_free (sym_tree
);
2412 /* Free a derived type list. */
2415 gfc_free_dt_list (gfc_dt_list
* dt
)
2427 /* Free the gfc_equiv_info's. */
2430 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2434 gfc_free_equiv_infos (s
->next
);
2439 /* Free the gfc_equiv_lists. */
2442 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2446 gfc_free_equiv_lists (l
->next
);
2447 gfc_free_equiv_infos (l
->equiv
);
2452 /* Free a namespace structure and everything below it. Interface
2453 lists associated with intrinsic operators are not freed. These are
2454 taken care of when a specific name is freed. */
2457 gfc_free_namespace (gfc_namespace
* ns
)
2459 gfc_charlen
*cl
, *cl2
;
2460 gfc_namespace
*p
, *q
;
2469 gcc_assert (ns
->refs
== 0);
2471 gfc_free_statements (ns
->code
);
2473 free_sym_tree (ns
->sym_root
);
2474 free_uop_tree (ns
->uop_root
);
2475 free_common_tree (ns
->common_root
);
2477 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2480 gfc_free_expr (cl
->length
);
2484 free_st_labels (ns
->st_labels
);
2486 gfc_free_equiv (ns
->equiv
);
2487 gfc_free_equiv_lists (ns
->equiv_lists
);
2489 gfc_free_dt_list (ns
->derived_types
);
2491 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2492 gfc_free_interface (ns
->operator[i
]);
2494 gfc_free_data (ns
->data
);
2498 /* Recursively free any contained namespaces. */
2504 gfc_free_namespace (q
);
2510 gfc_symbol_init_2 (void)
2513 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2518 gfc_symbol_done_2 (void)
2521 gfc_free_namespace (gfc_current_ns
);
2522 gfc_current_ns
= NULL
;
2526 /* Clear mark bits from symbol nodes associated with a symtree node. */
2529 clear_sym_mark (gfc_symtree
* st
)
2532 st
->n
.sym
->mark
= 0;
2536 /* Recursively traverse the symtree nodes. */
2539 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2545 gfc_traverse_symtree (st
->left
, func
);
2546 gfc_traverse_symtree (st
->right
, func
);
2551 /* Recursive namespace traversal function. */
2554 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2560 if (st
->n
.sym
->mark
== 0)
2561 (*func
) (st
->n
.sym
);
2562 st
->n
.sym
->mark
= 1;
2564 traverse_ns (st
->left
, func
);
2565 traverse_ns (st
->right
, func
);
2569 /* Call a given function for all symbols in the namespace. We take
2570 care that each gfc_symbol node is called exactly once. */
2573 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2576 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2578 traverse_ns (ns
->sym_root
, func
);
2582 /* Return TRUE if the symbol is an automatic variable. */
2584 gfc_is_var_automatic (gfc_symbol
* sym
)
2586 /* Pointer and allocatable variables are never automatic. */
2587 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2589 /* Check for arrays with non-constant size. */
2590 if (sym
->attr
.dimension
&& sym
->as
2591 && !gfc_is_compile_time_shape (sym
->as
))
2593 /* Check for non-constant length character variables. */
2594 if (sym
->ts
.type
== BT_CHARACTER
2596 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2601 /* Given a symbol, mark it as SAVEd if it is allowed. */
2604 save_symbol (gfc_symbol
* sym
)
2607 if (sym
->attr
.use_assoc
)
2610 if (sym
->attr
.in_common
2612 || sym
->attr
.flavor
!= FL_VARIABLE
)
2614 /* Automatic objects are not saved. */
2615 if (gfc_is_var_automatic (sym
))
2617 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2621 /* Mark those symbols which can be SAVEd as such. */
2624 gfc_save_all (gfc_namespace
* ns
)
2627 gfc_traverse_ns (ns
, save_symbol
);
2632 /* Make sure that no changes to symbols are pending. */
2635 gfc_symbol_state(void) {
2637 if (changed_syms
!= NULL
)
2638 gfc_internal_error("Symbol changes still pending!");
2643 /************** Global symbol handling ************/
2646 /* Search a tree for the global symbol. */
2649 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2655 if (strcmp (symbol
->name
, name
) == 0)
2658 s
= gfc_find_gsymbol (symbol
->left
, name
);
2662 s
= gfc_find_gsymbol (symbol
->right
, name
);
2670 /* Compare two global symbols. Used for managing the BB tree. */
2673 gsym_compare (void * _s1
, void * _s2
)
2675 gfc_gsymbol
*s1
, *s2
;
2677 s1
= (gfc_gsymbol
*)_s1
;
2678 s2
= (gfc_gsymbol
*)_s2
;
2679 return strcmp(s1
->name
, s2
->name
);
2683 /* Get a global symbol, creating it if it doesn't exist. */
2686 gfc_get_gsymbol (const char *name
)
2690 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2694 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2695 s
->type
= GSYM_UNKNOWN
;
2696 s
->name
= gfc_get_string (name
);
2698 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);