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
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
97 /* The following static variable indicates whether a particular element has
98 been explicitly set or not. */
100 static int new_flag
[GFC_LETTERS
];
103 /* Handle a correctly parsed IMPLICIT NONE. */
106 gfc_set_implicit_none (void)
110 if (gfc_current_ns
->seen_implicit_none
)
112 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
116 gfc_current_ns
->seen_implicit_none
= 1;
118 for (i
= 0; i
< GFC_LETTERS
; i
++)
120 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
121 gfc_current_ns
->set_flag
[i
] = 1;
126 /* Reset the implicit range flags. */
129 gfc_clear_new_implicit (void)
133 for (i
= 0; i
< GFC_LETTERS
; i
++)
138 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
141 gfc_add_new_implicit_range (int c1
, int c2
)
148 for (i
= c1
; i
<= c2
; i
++)
152 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
165 the new implicit types back into the existing types will work. */
168 gfc_merge_new_implicit (gfc_typespec
* ts
)
172 if (gfc_current_ns
->seen_implicit_none
)
174 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
178 for (i
= 0; i
< GFC_LETTERS
; i
++)
183 if (gfc_current_ns
->set_flag
[i
])
185 gfc_error ("Letter %c already has an IMPLICIT type at %C",
189 gfc_current_ns
->default_type
[i
] = *ts
;
190 gfc_current_ns
->set_flag
[i
] = 1;
197 /* Given a symbol, return a pointer to the typespec for its default type. */
200 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
204 letter
= sym
->name
[0];
205 if (letter
< 'a' || letter
> 'z')
206 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
211 return &ns
->default_type
[letter
- 'a'];
215 /* Given a pointer to a symbol, set its type according to the first
216 letter of its name. Fails if the letter in question has no default
220 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
224 if (sym
->ts
.type
!= BT_UNKNOWN
)
225 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
227 ts
= gfc_get_default_type (sym
, ns
);
229 if (ts
->type
== BT_UNKNOWN
)
231 if (error_flag
&& !sym
->attr
.untyped
)
233 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
234 sym
->name
, &sym
->declared_at
);
235 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
242 sym
->attr
.implicit_type
= 1;
248 /******************** Symbol attribute stuff *********************/
250 /* This is a generic conflict-checker. We do this to avoid having a
251 single conflict in two places. */
253 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
254 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
255 #define conf_std(a, b, std) if (attr->a && attr->b)\
264 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
266 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
267 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
268 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
269 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
270 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
271 *private = "PRIVATE", *recursive
= "RECURSIVE",
272 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
273 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
274 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
275 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
276 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
277 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
278 *volatile_
= "VOLATILE";
279 static const char *threadprivate
= "THREADPRIVATE";
285 where
= &gfc_current_locus
;
287 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
294 /* Check for attributes not allowed in a BLOCK DATA. */
295 if (gfc_current_state () == COMP_BLOCK_DATA
)
299 if (attr
->in_namelist
)
301 if (attr
->allocatable
)
307 if (attr
->access
== ACCESS_PRIVATE
)
309 if (attr
->access
== ACCESS_PUBLIC
)
311 if (attr
->intent
!= INTENT_UNKNOWN
)
317 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
324 conf (dummy
, intrinsic
);
326 conf (dummy
, threadprivate
);
327 conf (pointer
, target
);
328 conf (pointer
, external
);
329 conf (pointer
, intrinsic
);
330 conf (pointer
, elemental
);
331 conf (allocatable
, elemental
);
333 conf (target
, external
);
334 conf (target
, intrinsic
);
335 conf (external
, dimension
); /* See Fortran 95's R504. */
337 conf (external
, intrinsic
);
339 if (attr
->if_source
|| attr
->contained
)
341 conf (external
, subroutine
);
342 conf (external
, function
);
345 conf (allocatable
, pointer
);
346 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
347 conf_std (allocatable
, function
, GFC_STD_F2003
);
348 conf_std (allocatable
, result
, GFC_STD_F2003
);
349 conf (elemental
, recursive
);
351 conf (in_common
, dummy
);
352 conf (in_common
, allocatable
);
353 conf (in_common
, result
);
354 conf (in_common
, save
);
357 conf (dummy
, result
);
359 conf (in_equivalence
, use_assoc
);
360 conf (in_equivalence
, dummy
);
361 conf (in_equivalence
, target
);
362 conf (in_equivalence
, pointer
);
363 conf (in_equivalence
, function
);
364 conf (in_equivalence
, result
);
365 conf (in_equivalence
, entry
);
366 conf (in_equivalence
, allocatable
);
367 conf (in_equivalence
, threadprivate
);
369 conf (in_namelist
, pointer
);
370 conf (in_namelist
, allocatable
);
372 conf (entry
, result
);
374 conf (function
, subroutine
);
376 /* Cray pointer/pointee conflicts. */
377 conf (cray_pointer
, cray_pointee
);
378 conf (cray_pointer
, dimension
);
379 conf (cray_pointer
, pointer
);
380 conf (cray_pointer
, target
);
381 conf (cray_pointer
, allocatable
);
382 conf (cray_pointer
, external
);
383 conf (cray_pointer
, intrinsic
);
384 conf (cray_pointer
, in_namelist
);
385 conf (cray_pointer
, function
);
386 conf (cray_pointer
, subroutine
);
387 conf (cray_pointer
, entry
);
389 conf (cray_pointee
, allocatable
);
390 conf (cray_pointee
, intent
);
391 conf (cray_pointee
, optional
);
392 conf (cray_pointee
, dummy
);
393 conf (cray_pointee
, target
);
394 conf (cray_pointee
, intrinsic
);
395 conf (cray_pointee
, pointer
);
396 conf (cray_pointee
, entry
);
397 conf (cray_pointee
, in_common
);
398 conf (cray_pointee
, in_equivalence
);
399 conf (cray_pointee
, threadprivate
);
402 conf (data
, function
);
404 conf (data
, allocatable
);
405 conf (data
, use_assoc
);
407 conf (value
, pointer
)
408 conf (value
, allocatable
)
409 conf (value
, subroutine
)
410 conf (value
, function
)
411 conf (value
, volatile_
)
412 conf (value
, dimension
)
413 conf (value
, external
)
415 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
418 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
422 conf (volatile_
, intrinsic
)
423 conf (volatile_
, external
)
425 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
432 a1
= gfc_code2string (flavors
, attr
->flavor
);
434 if (attr
->in_namelist
435 && attr
->flavor
!= FL_VARIABLE
436 && attr
->flavor
!= FL_UNKNOWN
)
443 switch (attr
->flavor
)
463 conf2 (threadprivate
);
474 if (attr
->subroutine
)
483 conf2(threadprivate
);
488 case PROC_ST_FUNCTION
:
501 conf2 (threadprivate
);
522 conf2 (threadprivate
);
524 if (attr
->intent
!= INTENT_UNKNOWN
)
546 conf2 (threadprivate
);
557 gfc_error ("%s attribute conflicts with %s attribute at %L",
560 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
561 a1
, a2
, name
, where
);
568 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
569 "conflicts with %s attribute at %L", a1
, a2
,
574 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
575 "conflicts with %s attribute in '%s' at %L",
576 a1
, a2
, name
, where
);
585 /* Mark a symbol as referenced. */
588 gfc_set_sym_referenced (gfc_symbol
* sym
)
590 if (sym
->attr
.referenced
)
593 sym
->attr
.referenced
= 1;
595 /* Remember which order dummy variables are accessed in. */
597 sym
->dummy_order
= next_dummy_order
++;
601 /* Common subroutine called by attribute changing subroutines in order
602 to prevent them from changing a symbol that has been
603 use-associated. Returns zero if it is OK to change the symbol,
607 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
610 if (attr
->use_assoc
== 0)
614 where
= &gfc_current_locus
;
617 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
620 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
627 /* Generate an error because of a duplicate attribute. */
630 duplicate_attr (const char *attr
, locus
* where
)
634 where
= &gfc_current_locus
;
636 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
639 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
642 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
644 if (check_used (attr
, NULL
, where
))
647 return check_conflict (attr
, NULL
, where
);
651 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
654 if (check_used (attr
, NULL
, where
))
657 if (attr
->allocatable
)
659 duplicate_attr ("ALLOCATABLE", where
);
663 attr
->allocatable
= 1;
664 return check_conflict (attr
, NULL
, where
);
669 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
672 if (check_used (attr
, name
, where
))
677 duplicate_attr ("DIMENSION", where
);
682 return check_conflict (attr
, name
, where
);
687 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
690 if (check_used (attr
, NULL
, where
))
695 duplicate_attr ("EXTERNAL", where
);
701 return check_conflict (attr
, NULL
, where
);
706 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
709 if (check_used (attr
, NULL
, where
))
714 duplicate_attr ("INTRINSIC", where
);
720 return check_conflict (attr
, NULL
, where
);
725 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
728 if (check_used (attr
, NULL
, where
))
733 duplicate_attr ("OPTIONAL", where
);
738 return check_conflict (attr
, NULL
, where
);
743 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
746 if (check_used (attr
, NULL
, where
))
750 return check_conflict (attr
, NULL
, where
);
755 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
758 if (check_used (attr
, NULL
, where
))
761 attr
->cray_pointer
= 1;
762 return check_conflict (attr
, NULL
, where
);
767 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
770 if (check_used (attr
, NULL
, where
))
773 if (attr
->cray_pointee
)
775 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
776 " statements", where
);
780 attr
->cray_pointee
= 1;
781 return check_conflict (attr
, NULL
, where
);
786 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
789 if (check_used (attr
, name
, where
))
793 return check_conflict (attr
, name
, where
);
798 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
801 if (check_used (attr
, name
, where
))
807 ("SAVE attribute at %L cannot be specified in a PURE procedure",
814 if (gfc_notify_std (GFC_STD_LEGACY
,
815 "Duplicate SAVE attribute specified at %L",
822 return check_conflict (attr
, name
, where
);
826 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
829 if (check_used (attr
, name
, where
))
834 if (gfc_notify_std (GFC_STD_LEGACY
,
835 "Duplicate VALUE attribute specified at %L",
842 return check_conflict (attr
, name
, where
);
846 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
849 if (check_used (attr
, name
, where
))
854 if (gfc_notify_std (GFC_STD_LEGACY
,
855 "Duplicate VOLATILE attribute specified at %L",
862 return check_conflict (attr
, name
, where
);
867 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
869 if (check_used (attr
, name
, where
))
872 if (attr
->threadprivate
)
874 duplicate_attr ("THREADPRIVATE", where
);
878 attr
->threadprivate
= 1;
879 return check_conflict (attr
, name
, where
);
884 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
887 if (check_used (attr
, NULL
, where
))
892 duplicate_attr ("TARGET", where
);
897 return check_conflict (attr
, NULL
, where
);
902 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
905 if (check_used (attr
, name
, where
))
908 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
910 return check_conflict (attr
, name
, where
);
915 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
918 if (check_used (attr
, name
, where
))
921 /* Duplicate attribute already checked for. */
923 if (check_conflict (attr
, name
, where
) == FAILURE
)
926 if (attr
->flavor
== FL_VARIABLE
)
929 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
933 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
936 /* Duplicate attribute already checked for. */
937 attr
->in_equivalence
= 1;
938 if (check_conflict (attr
, name
, where
) == FAILURE
)
941 if (attr
->flavor
== FL_VARIABLE
)
944 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
949 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
952 if (check_used (attr
, name
, where
))
956 return check_conflict (attr
, name
, where
);
961 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
965 attr
->in_namelist
= 1;
966 return check_conflict (attr
, name
, where
);
971 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
974 if (check_used (attr
, name
, where
))
978 return check_conflict (attr
, name
, where
);
983 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
986 if (check_used (attr
, NULL
, where
))
990 return check_conflict (attr
, NULL
, where
);
995 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
998 if (check_used (attr
, NULL
, where
))
1002 return check_conflict (attr
, NULL
, where
);
1007 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1010 if (check_used (attr
, NULL
, where
))
1013 attr
->recursive
= 1;
1014 return check_conflict (attr
, NULL
, where
);
1019 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1022 if (check_used (attr
, name
, where
))
1027 duplicate_attr ("ENTRY", where
);
1032 return check_conflict (attr
, name
, where
);
1037 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1040 if (attr
->flavor
!= FL_PROCEDURE
1041 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1045 return check_conflict (attr
, name
, where
);
1050 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1053 if (attr
->flavor
!= FL_PROCEDURE
1054 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1057 attr
->subroutine
= 1;
1058 return check_conflict (attr
, name
, where
);
1063 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1066 if (attr
->flavor
!= FL_PROCEDURE
1067 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1071 return check_conflict (attr
, name
, where
);
1075 /* Flavors are special because some flavors are not what Fortran
1076 considers attributes and can be reaffirmed multiple times. */
1079 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1083 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1084 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1085 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1088 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1091 if (attr
->flavor
!= FL_UNKNOWN
)
1094 where
= &gfc_current_locus
;
1096 gfc_error ("%s attribute conflicts with %s attribute at %L",
1097 gfc_code2string (flavors
, attr
->flavor
),
1098 gfc_code2string (flavors
, f
), where
);
1105 return check_conflict (attr
, name
, where
);
1110 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1111 const char *name
, locus
* where
)
1114 if (check_used (attr
, name
, where
))
1117 if (attr
->flavor
!= FL_PROCEDURE
1118 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1122 where
= &gfc_current_locus
;
1124 if (attr
->proc
!= PROC_UNKNOWN
)
1126 gfc_error ("%s procedure at %L is already declared as %s procedure",
1127 gfc_code2string (procedures
, t
), where
,
1128 gfc_code2string (procedures
, attr
->proc
));
1135 /* Statement functions are always scalar and functions. */
1136 if (t
== PROC_ST_FUNCTION
1137 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1138 || attr
->dimension
))
1141 return check_conflict (attr
, name
, where
);
1146 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1149 if (check_used (attr
, NULL
, where
))
1152 if (attr
->intent
== INTENT_UNKNOWN
)
1154 attr
->intent
= intent
;
1155 return check_conflict (attr
, NULL
, where
);
1159 where
= &gfc_current_locus
;
1161 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1162 gfc_intent_string (attr
->intent
),
1163 gfc_intent_string (intent
), where
);
1169 /* No checks for use-association in public and private statements. */
1172 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1173 const char *name
, locus
* where
)
1176 if (attr
->access
== ACCESS_UNKNOWN
)
1178 attr
->access
= access
;
1179 return check_conflict (attr
, name
, where
);
1183 where
= &gfc_current_locus
;
1184 gfc_error ("ACCESS specification at %L was already specified", where
);
1191 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1192 gfc_formal_arglist
* formal
, locus
* where
)
1195 if (check_used (&sym
->attr
, sym
->name
, where
))
1199 where
= &gfc_current_locus
;
1201 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1202 && sym
->attr
.if_source
!= IFSRC_DECL
)
1204 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1209 sym
->formal
= formal
;
1210 sym
->attr
.if_source
= source
;
1216 /* Add a type to a symbol. */
1219 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1224 where
= &gfc_current_locus
;
1226 if (sym
->ts
.type
!= BT_UNKNOWN
)
1228 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1229 if (!(sym
->ts
.type
== ts
->type
1230 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1231 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1234 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1237 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1238 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1242 flavor
= sym
->attr
.flavor
;
1244 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1245 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1246 && sym
->attr
.subroutine
)
1247 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1249 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1258 /* Clears all attributes. */
1261 gfc_clear_attr (symbol_attribute
* attr
)
1263 memset (attr
, 0, sizeof(symbol_attribute
));
1267 /* Check for missing attributes in the new symbol. Currently does
1268 nothing, but it's not clear that it is unnecessary yet. */
1271 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1272 locus
* where ATTRIBUTE_UNUSED
)
1279 /* Copy an attribute to a symbol attribute, bit by bit. Some
1280 attributes have a lot of side-effects but cannot be present given
1281 where we are called from, so we ignore some bits. */
1284 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1287 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1290 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1292 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1294 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1296 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1298 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1300 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1302 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1304 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1306 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1308 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1313 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1316 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1319 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1321 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1323 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1326 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1328 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1330 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1332 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1335 if (src
->flavor
!= FL_UNKNOWN
1336 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1339 if (src
->intent
!= INTENT_UNKNOWN
1340 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1343 if (src
->access
!= ACCESS_UNKNOWN
1344 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1347 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1350 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1352 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1355 /* The subroutines that set these bits also cause flavors to be set,
1356 and that has already happened in the original, so don't let it
1361 dest
->intrinsic
= 1;
1370 /************** Component name management ************/
1372 /* Component names of a derived type form their own little namespaces
1373 that are separate from all other spaces. The space is composed of
1374 a singly linked list of gfc_component structures whose head is
1375 located in the parent symbol. */
1378 /* Add a component name to a symbol. The call fails if the name is
1379 already present. On success, the component pointer is modified to
1380 point to the additional component structure. */
1383 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1385 gfc_component
*p
, *tail
;
1389 for (p
= sym
->components
; p
; p
= p
->next
)
1391 if (strcmp (p
->name
, name
) == 0)
1393 gfc_error ("Component '%s' at %C already declared at %L",
1401 /* Allocate a new component. */
1402 p
= gfc_get_component ();
1405 sym
->components
= p
;
1409 p
->name
= gfc_get_string (name
);
1410 p
->loc
= gfc_current_locus
;
1417 /* Recursive function to switch derived types of all symbol in a
1421 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1429 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1430 sym
->ts
.derived
= to
;
1432 switch_types (st
->left
, from
, to
);
1433 switch_types (st
->right
, from
, to
);
1437 /* This subroutine is called when a derived type is used in order to
1438 make the final determination about which version to use. The
1439 standard requires that a type be defined before it is 'used', but
1440 such types can appear in IMPLICIT statements before the actual
1441 definition. 'Using' in this context means declaring a variable to
1442 be that type or using the type constructor.
1444 If a type is used and the components haven't been defined, then we
1445 have to have a derived type in a parent unit. We find the node in
1446 the other namespace and point the symtree node in this namespace to
1447 that node. Further reference to this name point to the correct
1448 node. If we can't find the node in a parent namespace, then we have
1451 This subroutine takes a pointer to a symbol node and returns a
1452 pointer to the translated node or NULL for an error. Usually there
1453 is no translation and we return the node we were passed. */
1456 gfc_use_derived (gfc_symbol
* sym
)
1463 if (sym
->components
!= NULL
)
1464 return sym
; /* Already defined. */
1466 if (sym
->ns
->parent
== NULL
)
1469 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1471 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1475 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1478 /* Get rid of symbol sym, translating all references to s. */
1479 for (i
= 0; i
< GFC_LETTERS
; i
++)
1481 t
= &sym
->ns
->default_type
[i
];
1482 if (t
->derived
== sym
)
1486 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1491 /* Unlink from list of modified symbols. */
1492 gfc_commit_symbol (sym
);
1494 switch_types (sym
->ns
->sym_root
, sym
, s
);
1496 /* TODO: Also have to replace sym -> s in other lists like
1497 namelists, common lists and interface lists. */
1498 gfc_free_symbol (sym
);
1503 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1509 /* Given a derived type node and a component name, try to locate the
1510 component structure. Returns the NULL pointer if the component is
1511 not found or the components are private. */
1514 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1521 sym
= gfc_use_derived (sym
);
1526 for (p
= sym
->components
; p
; p
= p
->next
)
1527 if (strcmp (p
->name
, name
) == 0)
1531 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1535 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1537 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1547 /* Given a symbol, free all of the component structures and everything
1551 free_components (gfc_component
* p
)
1559 gfc_free_array_spec (p
->as
);
1560 gfc_free_expr (p
->initializer
);
1567 /* Set component attributes from a standard symbol attribute
1571 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1574 c
->dimension
= attr
->dimension
;
1575 c
->pointer
= attr
->pointer
;
1576 c
->allocatable
= attr
->allocatable
;
1580 /* Get a standard symbol attribute structure given the component
1584 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1587 gfc_clear_attr (attr
);
1588 attr
->dimension
= c
->dimension
;
1589 attr
->pointer
= c
->pointer
;
1590 attr
->allocatable
= c
->allocatable
;
1594 /******************** Statement label management ********************/
1596 /* Comparison function for statement labels, used for managing the
1600 compare_st_labels (void * a1
, void * b1
)
1602 int a
= ((gfc_st_label
*)a1
)->value
;
1603 int b
= ((gfc_st_label
*)b1
)->value
;
1609 /* Free a single gfc_st_label structure, making sure the tree is not
1610 messed up. This function is called only when some parse error
1614 gfc_free_st_label (gfc_st_label
* label
)
1619 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1621 if (label
->format
!= NULL
)
1622 gfc_free_expr (label
->format
);
1627 /* Free a whole tree of gfc_st_label structures. */
1630 free_st_labels (gfc_st_label
* label
)
1635 free_st_labels (label
->left
);
1636 free_st_labels (label
->right
);
1638 if (label
->format
!= NULL
)
1639 gfc_free_expr (label
->format
);
1644 /* Given a label number, search for and return a pointer to the label
1645 structure, creating it if it does not exist. */
1648 gfc_get_st_label (int labelno
)
1652 /* First see if the label is already in this namespace. */
1653 lp
= gfc_current_ns
->st_labels
;
1656 if (lp
->value
== labelno
)
1659 if (lp
->value
< labelno
)
1665 lp
= gfc_getmem (sizeof (gfc_st_label
));
1667 lp
->value
= labelno
;
1668 lp
->defined
= ST_LABEL_UNKNOWN
;
1669 lp
->referenced
= ST_LABEL_UNKNOWN
;
1671 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1677 /* Called when a statement with a statement label is about to be
1678 accepted. We add the label to the list of the current namespace,
1679 making sure it hasn't been defined previously and referenced
1683 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1687 labelno
= lp
->value
;
1689 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1690 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1691 &lp
->where
, label_locus
);
1694 lp
->where
= *label_locus
;
1698 case ST_LABEL_FORMAT
:
1699 if (lp
->referenced
== ST_LABEL_TARGET
)
1700 gfc_error ("Label %d at %C already referenced as branch target",
1703 lp
->defined
= ST_LABEL_FORMAT
;
1707 case ST_LABEL_TARGET
:
1708 if (lp
->referenced
== ST_LABEL_FORMAT
)
1709 gfc_error ("Label %d at %C already referenced as a format label",
1712 lp
->defined
= ST_LABEL_TARGET
;
1717 lp
->defined
= ST_LABEL_BAD_TARGET
;
1718 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1724 /* Reference a label. Given a label and its type, see if that
1725 reference is consistent with what is known about that label,
1726 updating the unknown state. Returns FAILURE if something goes
1730 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1732 gfc_sl_type label_type
;
1739 labelno
= lp
->value
;
1741 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1742 label_type
= lp
->defined
;
1745 label_type
= lp
->referenced
;
1746 lp
->where
= gfc_current_locus
;
1749 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1751 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1756 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1757 && type
== ST_LABEL_FORMAT
)
1759 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1764 lp
->referenced
= type
;
1772 /************** Symbol table management subroutines ****************/
1774 /* Basic details: Fortran 95 requires a potentially unlimited number
1775 of distinct namespaces when compiling a program unit. This case
1776 occurs during a compilation of internal subprograms because all of
1777 the internal subprograms must be read before we can start
1778 generating code for the host.
1780 Given the tricky nature of the Fortran grammar, we must be able to
1781 undo changes made to a symbol table if the current interpretation
1782 of a statement is found to be incorrect. Whenever a symbol is
1783 looked up, we make a copy of it and link to it. All of these
1784 symbols are kept in a singly linked list so that we can commit or
1785 undo the changes at a later time.
1787 A symtree may point to a symbol node outside of its namespace. In
1788 this case, that symbol has been used as a host associated variable
1789 at some previous time. */
1791 /* Allocate a new namespace structure. Copies the implicit types from
1792 PARENT if PARENT_TYPES is set. */
1795 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1799 gfc_intrinsic_op in
;
1802 ns
= gfc_getmem (sizeof (gfc_namespace
));
1803 ns
->sym_root
= NULL
;
1804 ns
->uop_root
= NULL
;
1805 ns
->default_access
= ACCESS_UNKNOWN
;
1806 ns
->parent
= parent
;
1808 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1809 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1811 /* Initialize default implicit types. */
1812 for (i
= 'a'; i
<= 'z'; i
++)
1814 ns
->set_flag
[i
- 'a'] = 0;
1815 ts
= &ns
->default_type
[i
- 'a'];
1817 if (parent_types
&& ns
->parent
!= NULL
)
1819 /* Copy parent settings */
1820 *ts
= ns
->parent
->default_type
[i
- 'a'];
1824 if (gfc_option
.flag_implicit_none
!= 0)
1830 if ('i' <= i
&& i
<= 'n')
1832 ts
->type
= BT_INTEGER
;
1833 ts
->kind
= gfc_default_integer_kind
;
1838 ts
->kind
= gfc_default_real_kind
;
1848 /* Comparison function for symtree nodes. */
1851 compare_symtree (void * _st1
, void * _st2
)
1853 gfc_symtree
*st1
, *st2
;
1855 st1
= (gfc_symtree
*) _st1
;
1856 st2
= (gfc_symtree
*) _st2
;
1858 return strcmp (st1
->name
, st2
->name
);
1862 /* Allocate a new symtree node and associate it with the new symbol. */
1865 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1869 st
= gfc_getmem (sizeof (gfc_symtree
));
1870 st
->name
= gfc_get_string (name
);
1872 gfc_insert_bbt (root
, st
, compare_symtree
);
1877 /* Delete a symbol from the tree. Does not free the symbol itself! */
1880 delete_symtree (gfc_symtree
** root
, const char *name
)
1882 gfc_symtree st
, *st0
;
1884 st0
= gfc_find_symtree (*root
, name
);
1886 st
.name
= gfc_get_string (name
);
1887 gfc_delete_bbt (root
, &st
, compare_symtree
);
1893 /* Given a root symtree node and a name, try to find the symbol within
1894 the namespace. Returns NULL if the symbol is not found. */
1897 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1903 c
= strcmp (name
, st
->name
);
1907 st
= (c
< 0) ? st
->left
: st
->right
;
1914 /* Given a name find a user operator node, creating it if it doesn't
1915 exist. These are much simpler than symbols because they can't be
1916 ambiguous with one another. */
1919 gfc_get_uop (const char *name
)
1924 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1928 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1930 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1931 uop
->name
= gfc_get_string (name
);
1932 uop
->access
= ACCESS_UNKNOWN
;
1933 uop
->ns
= gfc_current_ns
;
1939 /* Given a name find the user operator node. Returns NULL if it does
1943 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1948 ns
= gfc_current_ns
;
1950 st
= gfc_find_symtree (ns
->uop_root
, name
);
1951 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1955 /* Remove a gfc_symbol structure and everything it points to. */
1958 gfc_free_symbol (gfc_symbol
* sym
)
1964 gfc_free_array_spec (sym
->as
);
1966 free_components (sym
->components
);
1968 gfc_free_expr (sym
->value
);
1970 gfc_free_namelist (sym
->namelist
);
1972 gfc_free_namespace (sym
->formal_ns
);
1974 if (!sym
->attr
.generic_copy
)
1975 gfc_free_interface (sym
->generic
);
1977 gfc_free_formal_arglist (sym
->formal
);
1983 /* Allocate and initialize a new symbol node. */
1986 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1990 p
= gfc_getmem (sizeof (gfc_symbol
));
1992 gfc_clear_ts (&p
->ts
);
1993 gfc_clear_attr (&p
->attr
);
1996 p
->declared_at
= gfc_current_locus
;
1998 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1999 gfc_internal_error ("new_symbol(): Symbol name too long");
2001 p
->name
= gfc_get_string (name
);
2006 /* Generate an error if a symbol is ambiguous. */
2009 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2012 if (st
->n
.sym
->module
)
2013 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2014 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2016 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2017 "from current program unit", name
, st
->n
.sym
->name
);
2021 /* Search for a symtree starting in the current namespace, resorting to
2022 any parent namespaces if requested by a nonzero parent_flag.
2023 Returns nonzero if the name is ambiguous. */
2026 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2027 gfc_symtree
** result
)
2032 ns
= gfc_current_ns
;
2036 st
= gfc_find_symtree (ns
->sym_root
, name
);
2042 ambiguous_symbol (name
, st
);
2061 /* Same, but returns the symbol instead. */
2064 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2065 gfc_symbol
** result
)
2070 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2075 *result
= st
->n
.sym
;
2081 /* Save symbol with the information necessary to back it out. */
2084 save_symbol_data (gfc_symbol
* sym
)
2087 if (sym
->new || sym
->old_symbol
!= NULL
)
2090 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2091 *(sym
->old_symbol
) = *sym
;
2093 sym
->tlink
= changed_syms
;
2098 /* Given a name, find a symbol, or create it if it does not exist yet
2099 in the current namespace. If the symbol is found we make sure that
2102 The integer return code indicates
2104 1 The symbol name was ambiguous
2105 2 The name meant to be established was already host associated.
2107 So if the return value is nonzero, then an error was issued. */
2110 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2115 /* This doesn't usually happen during resolution. */
2117 ns
= gfc_current_ns
;
2119 /* Try to find the symbol in ns. */
2120 st
= gfc_find_symtree (ns
->sym_root
, name
);
2124 /* If not there, create a new symbol. */
2125 p
= gfc_new_symbol (name
, ns
);
2127 /* Add to the list of tentative symbols. */
2128 p
->old_symbol
= NULL
;
2129 p
->tlink
= changed_syms
;
2134 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2141 /* Make sure the existing symbol is OK. */
2144 ambiguous_symbol (name
, st
);
2150 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2152 /* Symbol is from another namespace. */
2153 gfc_error ("Symbol '%s' at %C has already been host associated",
2160 /* Copy in case this symbol is changed. */
2161 save_symbol_data (p
);
2170 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2176 i
= gfc_get_sym_tree (name
, ns
, &st
);
2181 *result
= st
->n
.sym
;
2188 /* Subroutine that searches for a symbol, creating it if it doesn't
2189 exist, but tries to host-associate the symbol if possible. */
2192 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2197 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2200 save_symbol_data (st
->n
.sym
);
2206 if (gfc_current_ns
->parent
!= NULL
)
2208 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2219 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2224 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2229 i
= gfc_get_ha_sym_tree (name
, &st
);
2232 *result
= st
->n
.sym
;
2239 /* Return true if both symbols could refer to the same data object. Does
2240 not take account of aliasing due to equivalence statements. */
2243 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2245 /* Aliasing isn't possible if the symbols have different base types. */
2246 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2249 /* Pointers can point to other pointers, target objects and allocatable
2250 objects. Two allocatable objects cannot share the same storage. */
2251 if (lsym
->attr
.pointer
2252 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2254 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2256 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2263 /* Undoes all the changes made to symbols in the current statement.
2264 This subroutine is made simpler due to the fact that attributes are
2265 never removed once added. */
2268 gfc_undo_symbols (void)
2270 gfc_symbol
*p
, *q
, *old
;
2272 for (p
= changed_syms
; p
; p
= q
)
2278 /* Symbol was new. */
2279 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2283 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2285 gfc_free_symbol (p
);
2289 /* Restore previous state of symbol. Just copy simple stuff. */
2291 old
= p
->old_symbol
;
2293 p
->ts
.type
= old
->ts
.type
;
2294 p
->ts
.kind
= old
->ts
.kind
;
2296 p
->attr
= old
->attr
;
2298 if (p
->value
!= old
->value
)
2300 gfc_free_expr (old
->value
);
2304 if (p
->as
!= old
->as
)
2307 gfc_free_array_spec (p
->as
);
2311 p
->generic
= old
->generic
;
2312 p
->component_access
= old
->component_access
;
2314 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2316 gfc_free_namelist (p
->namelist
);
2322 if (p
->namelist_tail
!= old
->namelist_tail
)
2324 gfc_free_namelist (old
->namelist_tail
);
2325 old
->namelist_tail
->next
= NULL
;
2329 p
->namelist_tail
= old
->namelist_tail
;
2331 if (p
->formal
!= old
->formal
)
2333 gfc_free_formal_arglist (p
->formal
);
2334 p
->formal
= old
->formal
;
2337 gfc_free (p
->old_symbol
);
2338 p
->old_symbol
= NULL
;
2342 changed_syms
= NULL
;
2346 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2347 components of old_symbol that might need deallocation are the "allocatables"
2348 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2349 namelist_tail. In case these differ between old_symbol and sym, it's just
2350 because sym->namelist has gotten a few more items. */
2353 free_old_symbol (gfc_symbol
* sym
)
2355 if (sym
->old_symbol
== NULL
)
2358 if (sym
->old_symbol
->as
!= sym
->as
)
2359 gfc_free_array_spec (sym
->old_symbol
->as
);
2361 if (sym
->old_symbol
->value
!= sym
->value
)
2362 gfc_free_expr (sym
->old_symbol
->value
);
2364 if (sym
->old_symbol
->formal
!= sym
->formal
)
2365 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2367 gfc_free (sym
->old_symbol
);
2368 sym
->old_symbol
= NULL
;
2372 /* Makes the changes made in the current statement permanent-- gets
2373 rid of undo information. */
2376 gfc_commit_symbols (void)
2380 for (p
= changed_syms
; p
; p
= q
)
2387 free_old_symbol (p
);
2389 changed_syms
= NULL
;
2393 /* Makes the changes made in one symbol permanent -- gets rid of undo
2397 gfc_commit_symbol (gfc_symbol
* sym
)
2401 if (changed_syms
== sym
)
2402 changed_syms
= sym
->tlink
;
2405 for (p
= changed_syms
; p
; p
= p
->tlink
)
2406 if (p
->tlink
== sym
)
2408 p
->tlink
= sym
->tlink
;
2417 free_old_symbol (sym
);
2421 /* Recursive function that deletes an entire tree and all the common
2422 head structures it points to. */
2425 free_common_tree (gfc_symtree
* common_tree
)
2427 if (common_tree
== NULL
)
2430 free_common_tree (common_tree
->left
);
2431 free_common_tree (common_tree
->right
);
2433 gfc_free (common_tree
);
2437 /* Recursive function that deletes an entire tree and all the user
2438 operator nodes that it contains. */
2441 free_uop_tree (gfc_symtree
* uop_tree
)
2444 if (uop_tree
== NULL
)
2447 free_uop_tree (uop_tree
->left
);
2448 free_uop_tree (uop_tree
->right
);
2450 gfc_free_interface (uop_tree
->n
.uop
->operator);
2452 gfc_free (uop_tree
->n
.uop
);
2453 gfc_free (uop_tree
);
2457 /* Recursive function that deletes an entire tree and all the symbols
2458 that it contains. */
2461 free_sym_tree (gfc_symtree
* sym_tree
)
2466 if (sym_tree
== NULL
)
2469 free_sym_tree (sym_tree
->left
);
2470 free_sym_tree (sym_tree
->right
);
2472 sym
= sym_tree
->n
.sym
;
2476 gfc_internal_error ("free_sym_tree(): Negative refs");
2478 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2480 /* As formal_ns contains a reference to sym, delete formal_ns just
2481 before the deletion of sym. */
2482 ns
= sym
->formal_ns
;
2483 sym
->formal_ns
= NULL
;
2484 gfc_free_namespace (ns
);
2486 else if (sym
->refs
== 0)
2488 /* Go ahead and delete the symbol. */
2489 gfc_free_symbol (sym
);
2492 gfc_free (sym_tree
);
2496 /* Free a derived type list. */
2499 gfc_free_dt_list (gfc_dt_list
* dt
)
2511 /* Free the gfc_equiv_info's. */
2514 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2518 gfc_free_equiv_infos (s
->next
);
2523 /* Free the gfc_equiv_lists. */
2526 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2530 gfc_free_equiv_lists (l
->next
);
2531 gfc_free_equiv_infos (l
->equiv
);
2536 /* Free a namespace structure and everything below it. Interface
2537 lists associated with intrinsic operators are not freed. These are
2538 taken care of when a specific name is freed. */
2541 gfc_free_namespace (gfc_namespace
* ns
)
2543 gfc_charlen
*cl
, *cl2
;
2544 gfc_namespace
*p
, *q
;
2553 gcc_assert (ns
->refs
== 0);
2555 gfc_free_statements (ns
->code
);
2557 free_sym_tree (ns
->sym_root
);
2558 free_uop_tree (ns
->uop_root
);
2559 free_common_tree (ns
->common_root
);
2561 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2564 gfc_free_expr (cl
->length
);
2568 free_st_labels (ns
->st_labels
);
2570 gfc_free_equiv (ns
->equiv
);
2571 gfc_free_equiv_lists (ns
->equiv_lists
);
2573 gfc_free_dt_list (ns
->derived_types
);
2575 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2576 gfc_free_interface (ns
->operator[i
]);
2578 gfc_free_data (ns
->data
);
2582 /* Recursively free any contained namespaces. */
2588 gfc_free_namespace (q
);
2594 gfc_symbol_init_2 (void)
2597 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2602 gfc_symbol_done_2 (void)
2605 gfc_free_namespace (gfc_current_ns
);
2606 gfc_current_ns
= NULL
;
2610 /* Clear mark bits from symbol nodes associated with a symtree node. */
2613 clear_sym_mark (gfc_symtree
* st
)
2616 st
->n
.sym
->mark
= 0;
2620 /* Recursively traverse the symtree nodes. */
2623 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2629 gfc_traverse_symtree (st
->left
, func
);
2630 gfc_traverse_symtree (st
->right
, func
);
2635 /* Recursive namespace traversal function. */
2638 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2644 if (st
->n
.sym
->mark
== 0)
2645 (*func
) (st
->n
.sym
);
2646 st
->n
.sym
->mark
= 1;
2648 traverse_ns (st
->left
, func
);
2649 traverse_ns (st
->right
, func
);
2653 /* Call a given function for all symbols in the namespace. We take
2654 care that each gfc_symbol node is called exactly once. */
2657 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2660 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2662 traverse_ns (ns
->sym_root
, func
);
2666 /* Return TRUE if the symbol is an automatic variable. */
2668 gfc_is_var_automatic (gfc_symbol
* sym
)
2670 /* Pointer and allocatable variables are never automatic. */
2671 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2673 /* Check for arrays with non-constant size. */
2674 if (sym
->attr
.dimension
&& sym
->as
2675 && !gfc_is_compile_time_shape (sym
->as
))
2677 /* Check for non-constant length character variables. */
2678 if (sym
->ts
.type
== BT_CHARACTER
2680 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2685 /* Given a symbol, mark it as SAVEd if it is allowed. */
2688 save_symbol (gfc_symbol
* sym
)
2691 if (sym
->attr
.use_assoc
)
2694 if (sym
->attr
.in_common
2696 || sym
->attr
.flavor
!= FL_VARIABLE
)
2698 /* Automatic objects are not saved. */
2699 if (gfc_is_var_automatic (sym
))
2701 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2705 /* Mark those symbols which can be SAVEd as such. */
2708 gfc_save_all (gfc_namespace
* ns
)
2711 gfc_traverse_ns (ns
, save_symbol
);
2716 /* Make sure that no changes to symbols are pending. */
2719 gfc_symbol_state(void) {
2721 if (changed_syms
!= NULL
)
2722 gfc_internal_error("Symbol changes still pending!");
2727 /************** Global symbol handling ************/
2730 /* Search a tree for the global symbol. */
2733 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2739 if (strcmp (symbol
->name
, name
) == 0)
2742 s
= gfc_find_gsymbol (symbol
->left
, name
);
2746 s
= gfc_find_gsymbol (symbol
->right
, name
);
2754 /* Compare two global symbols. Used for managing the BB tree. */
2757 gsym_compare (void * _s1
, void * _s2
)
2759 gfc_gsymbol
*s1
, *s2
;
2761 s1
= (gfc_gsymbol
*)_s1
;
2762 s2
= (gfc_gsymbol
*)_s2
;
2763 return strcmp(s1
->name
, s2
->name
);
2767 /* Get a global symbol, creating it if it doesn't exist. */
2770 gfc_get_gsymbol (const char *name
)
2774 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2778 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2779 s
->type
= GSYM_UNKNOWN
;
2780 s
->name
= gfc_get_string (name
);
2782 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);