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 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
270 *private = "PRIVATE", *recursive
= "RECURSIVE",
271 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
272 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
273 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
274 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
275 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
276 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *volatile_
= "VOLATILE";
277 static const char *threadprivate
= "THREADPRIVATE";
283 where
= &gfc_current_locus
;
285 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
292 /* Check for attributes not allowed in a BLOCK DATA. */
293 if (gfc_current_state () == COMP_BLOCK_DATA
)
297 if (attr
->in_namelist
)
299 if (attr
->allocatable
)
305 if (attr
->access
== ACCESS_PRIVATE
)
307 if (attr
->access
== ACCESS_PUBLIC
)
309 if (attr
->intent
!= INTENT_UNKNOWN
)
315 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
322 conf (dummy
, intrinsic
);
324 conf (dummy
, threadprivate
);
325 conf (pointer
, target
);
326 conf (pointer
, external
);
327 conf (pointer
, intrinsic
);
328 conf (pointer
, elemental
);
329 conf (allocatable
, elemental
);
331 conf (target
, external
);
332 conf (target
, intrinsic
);
333 conf (external
, dimension
); /* See Fortran 95's R504. */
335 conf (external
, intrinsic
);
337 if (attr
->if_source
|| attr
->contained
)
339 conf (external
, subroutine
);
340 conf (external
, function
);
343 conf (allocatable
, pointer
);
344 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
345 conf_std (allocatable
, function
, GFC_STD_F2003
);
346 conf_std (allocatable
, result
, GFC_STD_F2003
);
347 conf (elemental
, recursive
);
349 conf (in_common
, dummy
);
350 conf (in_common
, allocatable
);
351 conf (in_common
, result
);
352 conf (in_common
, save
);
355 conf (dummy
, result
);
357 conf (in_equivalence
, use_assoc
);
358 conf (in_equivalence
, dummy
);
359 conf (in_equivalence
, target
);
360 conf (in_equivalence
, pointer
);
361 conf (in_equivalence
, function
);
362 conf (in_equivalence
, result
);
363 conf (in_equivalence
, entry
);
364 conf (in_equivalence
, allocatable
);
365 conf (in_equivalence
, threadprivate
);
367 conf (in_namelist
, pointer
);
368 conf (in_namelist
, allocatable
);
370 conf (entry
, result
);
372 conf (function
, subroutine
);
374 /* Cray pointer/pointee conflicts. */
375 conf (cray_pointer
, cray_pointee
);
376 conf (cray_pointer
, dimension
);
377 conf (cray_pointer
, pointer
);
378 conf (cray_pointer
, target
);
379 conf (cray_pointer
, allocatable
);
380 conf (cray_pointer
, external
);
381 conf (cray_pointer
, intrinsic
);
382 conf (cray_pointer
, in_namelist
);
383 conf (cray_pointer
, function
);
384 conf (cray_pointer
, subroutine
);
385 conf (cray_pointer
, entry
);
387 conf (cray_pointee
, allocatable
);
388 conf (cray_pointee
, intent
);
389 conf (cray_pointee
, optional
);
390 conf (cray_pointee
, dummy
);
391 conf (cray_pointee
, target
);
392 conf (cray_pointee
, intrinsic
);
393 conf (cray_pointee
, pointer
);
394 conf (cray_pointee
, entry
);
395 conf (cray_pointee
, in_common
);
396 conf (cray_pointee
, in_equivalence
);
397 conf (cray_pointee
, threadprivate
);
400 conf (data
, function
);
402 conf (data
, allocatable
);
403 conf (data
, use_assoc
);
405 conf (volatile_
, intrinsic
)
406 conf (volatile_
, external
)
408 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
415 a1
= gfc_code2string (flavors
, attr
->flavor
);
417 if (attr
->in_namelist
418 && attr
->flavor
!= FL_VARIABLE
419 && attr
->flavor
!= FL_UNKNOWN
)
426 switch (attr
->flavor
)
445 conf2 (threadprivate
);
456 if (attr
->subroutine
)
465 conf2(threadprivate
);
470 case PROC_ST_FUNCTION
:
483 conf2 (threadprivate
);
504 conf2 (threadprivate
);
506 if (attr
->intent
!= INTENT_UNKNOWN
)
527 conf2 (threadprivate
);
538 gfc_error ("%s attribute conflicts with %s attribute at %L",
541 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
542 a1
, a2
, name
, where
);
549 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
550 "conflicts with %s attribute at %L", a1
, a2
,
555 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
556 "conflicts with %s attribute in '%s' at %L",
557 a1
, a2
, name
, where
);
566 /* Mark a symbol as referenced. */
569 gfc_set_sym_referenced (gfc_symbol
* sym
)
571 if (sym
->attr
.referenced
)
574 sym
->attr
.referenced
= 1;
576 /* Remember which order dummy variables are accessed in. */
578 sym
->dummy_order
= next_dummy_order
++;
582 /* Common subroutine called by attribute changing subroutines in order
583 to prevent them from changing a symbol that has been
584 use-associated. Returns zero if it is OK to change the symbol,
588 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
591 if (attr
->use_assoc
== 0)
595 where
= &gfc_current_locus
;
598 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
601 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
608 /* Generate an error because of a duplicate attribute. */
611 duplicate_attr (const char *attr
, locus
* where
)
615 where
= &gfc_current_locus
;
617 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
620 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
623 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
625 if (check_used (attr
, NULL
, where
))
628 return check_conflict (attr
, NULL
, where
);
632 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
635 if (check_used (attr
, NULL
, where
))
638 if (attr
->allocatable
)
640 duplicate_attr ("ALLOCATABLE", where
);
644 attr
->allocatable
= 1;
645 return check_conflict (attr
, NULL
, where
);
650 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
653 if (check_used (attr
, name
, where
))
658 duplicate_attr ("DIMENSION", where
);
663 return check_conflict (attr
, name
, where
);
668 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
671 if (check_used (attr
, NULL
, where
))
676 duplicate_attr ("EXTERNAL", where
);
682 return check_conflict (attr
, NULL
, where
);
687 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
690 if (check_used (attr
, NULL
, where
))
695 duplicate_attr ("INTRINSIC", where
);
701 return check_conflict (attr
, NULL
, where
);
706 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
709 if (check_used (attr
, NULL
, where
))
714 duplicate_attr ("OPTIONAL", where
);
719 return check_conflict (attr
, NULL
, where
);
724 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
727 if (check_used (attr
, NULL
, where
))
731 return check_conflict (attr
, NULL
, where
);
736 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
739 if (check_used (attr
, NULL
, where
))
742 attr
->cray_pointer
= 1;
743 return check_conflict (attr
, NULL
, where
);
748 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
751 if (check_used (attr
, NULL
, where
))
754 if (attr
->cray_pointee
)
756 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
757 " statements.", where
);
761 attr
->cray_pointee
= 1;
762 return check_conflict (attr
, NULL
, where
);
767 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
770 if (check_used (attr
, name
, where
))
774 return check_conflict (attr
, name
, where
);
779 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
782 if (check_used (attr
, name
, where
))
788 ("SAVE attribute at %L cannot be specified in a PURE procedure",
795 if (gfc_notify_std (GFC_STD_LEGACY
,
796 "Duplicate SAVE attribute specified at %L",
803 return check_conflict (attr
, name
, where
);
807 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
810 if (check_used (attr
, name
, where
))
815 if (gfc_notify_std (GFC_STD_LEGACY
,
816 "Duplicate VOLATILE attribute specified at %L",
823 return check_conflict (attr
, name
, where
);
828 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
830 if (check_used (attr
, name
, where
))
833 if (attr
->threadprivate
)
835 duplicate_attr ("THREADPRIVATE", where
);
839 attr
->threadprivate
= 1;
840 return check_conflict (attr
, name
, where
);
845 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
848 if (check_used (attr
, NULL
, where
))
853 duplicate_attr ("TARGET", where
);
858 return check_conflict (attr
, NULL
, where
);
863 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
866 if (check_used (attr
, name
, where
))
869 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
871 return check_conflict (attr
, name
, where
);
876 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
879 if (check_used (attr
, name
, where
))
882 /* Duplicate attribute already checked for. */
884 if (check_conflict (attr
, name
, where
) == FAILURE
)
887 if (attr
->flavor
== FL_VARIABLE
)
890 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
894 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
897 /* Duplicate attribute already checked for. */
898 attr
->in_equivalence
= 1;
899 if (check_conflict (attr
, name
, where
) == FAILURE
)
902 if (attr
->flavor
== FL_VARIABLE
)
905 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
910 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
913 if (check_used (attr
, name
, where
))
917 return check_conflict (attr
, name
, where
);
922 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
926 attr
->in_namelist
= 1;
927 return check_conflict (attr
, name
, where
);
932 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
935 if (check_used (attr
, name
, where
))
939 return check_conflict (attr
, name
, where
);
944 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
947 if (check_used (attr
, NULL
, where
))
951 return check_conflict (attr
, NULL
, where
);
956 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
959 if (check_used (attr
, NULL
, where
))
963 return check_conflict (attr
, NULL
, where
);
968 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
971 if (check_used (attr
, NULL
, where
))
975 return check_conflict (attr
, NULL
, where
);
980 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
983 if (check_used (attr
, name
, where
))
988 duplicate_attr ("ENTRY", where
);
993 return check_conflict (attr
, name
, where
);
998 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1001 if (attr
->flavor
!= FL_PROCEDURE
1002 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1006 return check_conflict (attr
, name
, where
);
1011 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1014 if (attr
->flavor
!= FL_PROCEDURE
1015 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1018 attr
->subroutine
= 1;
1019 return check_conflict (attr
, name
, where
);
1024 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1027 if (attr
->flavor
!= FL_PROCEDURE
1028 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1032 return check_conflict (attr
, name
, where
);
1036 /* Flavors are special because some flavors are not what Fortran
1037 considers attributes and can be reaffirmed multiple times. */
1040 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1044 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1045 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1046 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1049 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1052 if (attr
->flavor
!= FL_UNKNOWN
)
1055 where
= &gfc_current_locus
;
1057 gfc_error ("%s attribute conflicts with %s attribute at %L",
1058 gfc_code2string (flavors
, attr
->flavor
),
1059 gfc_code2string (flavors
, f
), where
);
1066 return check_conflict (attr
, name
, where
);
1071 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1072 const char *name
, locus
* where
)
1075 if (check_used (attr
, name
, where
))
1078 if (attr
->flavor
!= FL_PROCEDURE
1079 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1083 where
= &gfc_current_locus
;
1085 if (attr
->proc
!= PROC_UNKNOWN
)
1087 gfc_error ("%s procedure at %L is already declared as %s procedure",
1088 gfc_code2string (procedures
, t
), where
,
1089 gfc_code2string (procedures
, attr
->proc
));
1096 /* Statement functions are always scalar and functions. */
1097 if (t
== PROC_ST_FUNCTION
1098 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1099 || attr
->dimension
))
1102 return check_conflict (attr
, name
, where
);
1107 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1110 if (check_used (attr
, NULL
, where
))
1113 if (attr
->intent
== INTENT_UNKNOWN
)
1115 attr
->intent
= intent
;
1116 return check_conflict (attr
, NULL
, where
);
1120 where
= &gfc_current_locus
;
1122 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1123 gfc_intent_string (attr
->intent
),
1124 gfc_intent_string (intent
), where
);
1130 /* No checks for use-association in public and private statements. */
1133 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1134 const char *name
, locus
* where
)
1137 if (attr
->access
== ACCESS_UNKNOWN
)
1139 attr
->access
= access
;
1140 return check_conflict (attr
, name
, where
);
1144 where
= &gfc_current_locus
;
1145 gfc_error ("ACCESS specification at %L was already specified", where
);
1152 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1153 gfc_formal_arglist
* formal
, locus
* where
)
1156 if (check_used (&sym
->attr
, sym
->name
, where
))
1160 where
= &gfc_current_locus
;
1162 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1163 && sym
->attr
.if_source
!= IFSRC_DECL
)
1165 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1170 sym
->formal
= formal
;
1171 sym
->attr
.if_source
= source
;
1177 /* Add a type to a symbol. */
1180 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1185 where
= &gfc_current_locus
;
1187 if (sym
->ts
.type
!= BT_UNKNOWN
)
1189 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1190 if (!(sym
->ts
.type
== ts
->type
1191 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1192 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1195 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1198 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1199 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1203 flavor
= sym
->attr
.flavor
;
1205 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1206 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1207 && sym
->attr
.subroutine
)
1208 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1210 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1219 /* Clears all attributes. */
1222 gfc_clear_attr (symbol_attribute
* attr
)
1224 memset (attr
, 0, sizeof(symbol_attribute
));
1228 /* Check for missing attributes in the new symbol. Currently does
1229 nothing, but it's not clear that it is unnecessary yet. */
1232 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1233 locus
* where ATTRIBUTE_UNUSED
)
1240 /* Copy an attribute to a symbol attribute, bit by bit. Some
1241 attributes have a lot of side-effects but cannot be present given
1242 where we are called from, so we ignore some bits. */
1245 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1248 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1251 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1253 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1255 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1257 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1259 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1261 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1263 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1265 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1267 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1272 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1275 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1278 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1280 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1282 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1285 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1287 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1289 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1291 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1294 if (src
->flavor
!= FL_UNKNOWN
1295 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1298 if (src
->intent
!= INTENT_UNKNOWN
1299 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1302 if (src
->access
!= ACCESS_UNKNOWN
1303 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1306 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1309 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1311 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1314 /* The subroutines that set these bits also cause flavors to be set,
1315 and that has already happened in the original, so don't let it
1320 dest
->intrinsic
= 1;
1329 /************** Component name management ************/
1331 /* Component names of a derived type form their own little namespaces
1332 that are separate from all other spaces. The space is composed of
1333 a singly linked list of gfc_component structures whose head is
1334 located in the parent symbol. */
1337 /* Add a component name to a symbol. The call fails if the name is
1338 already present. On success, the component pointer is modified to
1339 point to the additional component structure. */
1342 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1344 gfc_component
*p
, *tail
;
1348 for (p
= sym
->components
; p
; p
= p
->next
)
1350 if (strcmp (p
->name
, name
) == 0)
1352 gfc_error ("Component '%s' at %C already declared at %L",
1360 /* Allocate a new component. */
1361 p
= gfc_get_component ();
1364 sym
->components
= p
;
1368 p
->name
= gfc_get_string (name
);
1369 p
->loc
= gfc_current_locus
;
1376 /* Recursive function to switch derived types of all symbol in a
1380 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1388 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1389 sym
->ts
.derived
= to
;
1391 switch_types (st
->left
, from
, to
);
1392 switch_types (st
->right
, from
, to
);
1396 /* This subroutine is called when a derived type is used in order to
1397 make the final determination about which version to use. The
1398 standard requires that a type be defined before it is 'used', but
1399 such types can appear in IMPLICIT statements before the actual
1400 definition. 'Using' in this context means declaring a variable to
1401 be that type or using the type constructor.
1403 If a type is used and the components haven't been defined, then we
1404 have to have a derived type in a parent unit. We find the node in
1405 the other namespace and point the symtree node in this namespace to
1406 that node. Further reference to this name point to the correct
1407 node. If we can't find the node in a parent namespace, then we have
1410 This subroutine takes a pointer to a symbol node and returns a
1411 pointer to the translated node or NULL for an error. Usually there
1412 is no translation and we return the node we were passed. */
1415 gfc_use_derived (gfc_symbol
* sym
)
1422 if (sym
->components
!= NULL
)
1423 return sym
; /* Already defined. */
1425 if (sym
->ns
->parent
== NULL
)
1428 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1430 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1434 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1437 /* Get rid of symbol sym, translating all references to s. */
1438 for (i
= 0; i
< GFC_LETTERS
; i
++)
1440 t
= &sym
->ns
->default_type
[i
];
1441 if (t
->derived
== sym
)
1445 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1450 /* Unlink from list of modified symbols. */
1451 gfc_commit_symbol (sym
);
1453 switch_types (sym
->ns
->sym_root
, sym
, s
);
1455 /* TODO: Also have to replace sym -> s in other lists like
1456 namelists, common lists and interface lists. */
1457 gfc_free_symbol (sym
);
1462 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1468 /* Given a derived type node and a component name, try to locate the
1469 component structure. Returns the NULL pointer if the component is
1470 not found or the components are private. */
1473 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1480 sym
= gfc_use_derived (sym
);
1485 for (p
= sym
->components
; p
; p
= p
->next
)
1486 if (strcmp (p
->name
, name
) == 0)
1490 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1494 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1496 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1506 /* Given a symbol, free all of the component structures and everything
1510 free_components (gfc_component
* p
)
1518 gfc_free_array_spec (p
->as
);
1519 gfc_free_expr (p
->initializer
);
1526 /* Set component attributes from a standard symbol attribute
1530 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1533 c
->dimension
= attr
->dimension
;
1534 c
->pointer
= attr
->pointer
;
1535 c
->allocatable
= attr
->allocatable
;
1539 /* Get a standard symbol attribute structure given the component
1543 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1546 gfc_clear_attr (attr
);
1547 attr
->dimension
= c
->dimension
;
1548 attr
->pointer
= c
->pointer
;
1549 attr
->allocatable
= c
->allocatable
;
1553 /******************** Statement label management ********************/
1555 /* Comparison function for statement labels, used for managing the
1559 compare_st_labels (void * a1
, void * b1
)
1561 int a
= ((gfc_st_label
*)a1
)->value
;
1562 int b
= ((gfc_st_label
*)b1
)->value
;
1568 /* Free a single gfc_st_label structure, making sure the tree is not
1569 messed up. This function is called only when some parse error
1573 gfc_free_st_label (gfc_st_label
* label
)
1578 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1580 if (label
->format
!= NULL
)
1581 gfc_free_expr (label
->format
);
1586 /* Free a whole tree of gfc_st_label structures. */
1589 free_st_labels (gfc_st_label
* label
)
1594 free_st_labels (label
->left
);
1595 free_st_labels (label
->right
);
1597 if (label
->format
!= NULL
)
1598 gfc_free_expr (label
->format
);
1603 /* Given a label number, search for and return a pointer to the label
1604 structure, creating it if it does not exist. */
1607 gfc_get_st_label (int labelno
)
1611 /* First see if the label is already in this namespace. */
1612 lp
= gfc_current_ns
->st_labels
;
1615 if (lp
->value
== labelno
)
1618 if (lp
->value
< labelno
)
1624 lp
= gfc_getmem (sizeof (gfc_st_label
));
1626 lp
->value
= labelno
;
1627 lp
->defined
= ST_LABEL_UNKNOWN
;
1628 lp
->referenced
= ST_LABEL_UNKNOWN
;
1630 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1636 /* Called when a statement with a statement label is about to be
1637 accepted. We add the label to the list of the current namespace,
1638 making sure it hasn't been defined previously and referenced
1642 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1646 labelno
= lp
->value
;
1648 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1649 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1650 &lp
->where
, label_locus
);
1653 lp
->where
= *label_locus
;
1657 case ST_LABEL_FORMAT
:
1658 if (lp
->referenced
== ST_LABEL_TARGET
)
1659 gfc_error ("Label %d at %C already referenced as branch target",
1662 lp
->defined
= ST_LABEL_FORMAT
;
1666 case ST_LABEL_TARGET
:
1667 if (lp
->referenced
== ST_LABEL_FORMAT
)
1668 gfc_error ("Label %d at %C already referenced as a format label",
1671 lp
->defined
= ST_LABEL_TARGET
;
1676 lp
->defined
= ST_LABEL_BAD_TARGET
;
1677 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1683 /* Reference a label. Given a label and its type, see if that
1684 reference is consistent with what is known about that label,
1685 updating the unknown state. Returns FAILURE if something goes
1689 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1691 gfc_sl_type label_type
;
1698 labelno
= lp
->value
;
1700 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1701 label_type
= lp
->defined
;
1704 label_type
= lp
->referenced
;
1705 lp
->where
= gfc_current_locus
;
1708 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1710 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1715 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1716 && type
== ST_LABEL_FORMAT
)
1718 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1723 lp
->referenced
= type
;
1731 /************** Symbol table management subroutines ****************/
1733 /* Basic details: Fortran 95 requires a potentially unlimited number
1734 of distinct namespaces when compiling a program unit. This case
1735 occurs during a compilation of internal subprograms because all of
1736 the internal subprograms must be read before we can start
1737 generating code for the host.
1739 Given the tricky nature of the Fortran grammar, we must be able to
1740 undo changes made to a symbol table if the current interpretation
1741 of a statement is found to be incorrect. Whenever a symbol is
1742 looked up, we make a copy of it and link to it. All of these
1743 symbols are kept in a singly linked list so that we can commit or
1744 undo the changes at a later time.
1746 A symtree may point to a symbol node outside of its namespace. In
1747 this case, that symbol has been used as a host associated variable
1748 at some previous time. */
1750 /* Allocate a new namespace structure. Copies the implicit types from
1751 PARENT if PARENT_TYPES is set. */
1754 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1758 gfc_intrinsic_op in
;
1761 ns
= gfc_getmem (sizeof (gfc_namespace
));
1762 ns
->sym_root
= NULL
;
1763 ns
->uop_root
= NULL
;
1764 ns
->default_access
= ACCESS_UNKNOWN
;
1765 ns
->parent
= parent
;
1767 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1768 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1770 /* Initialize default implicit types. */
1771 for (i
= 'a'; i
<= 'z'; i
++)
1773 ns
->set_flag
[i
- 'a'] = 0;
1774 ts
= &ns
->default_type
[i
- 'a'];
1776 if (parent_types
&& ns
->parent
!= NULL
)
1778 /* Copy parent settings */
1779 *ts
= ns
->parent
->default_type
[i
- 'a'];
1783 if (gfc_option
.flag_implicit_none
!= 0)
1789 if ('i' <= i
&& i
<= 'n')
1791 ts
->type
= BT_INTEGER
;
1792 ts
->kind
= gfc_default_integer_kind
;
1797 ts
->kind
= gfc_default_real_kind
;
1807 /* Comparison function for symtree nodes. */
1810 compare_symtree (void * _st1
, void * _st2
)
1812 gfc_symtree
*st1
, *st2
;
1814 st1
= (gfc_symtree
*) _st1
;
1815 st2
= (gfc_symtree
*) _st2
;
1817 return strcmp (st1
->name
, st2
->name
);
1821 /* Allocate a new symtree node and associate it with the new symbol. */
1824 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1828 st
= gfc_getmem (sizeof (gfc_symtree
));
1829 st
->name
= gfc_get_string (name
);
1831 gfc_insert_bbt (root
, st
, compare_symtree
);
1836 /* Delete a symbol from the tree. Does not free the symbol itself! */
1839 delete_symtree (gfc_symtree
** root
, const char *name
)
1841 gfc_symtree st
, *st0
;
1843 st0
= gfc_find_symtree (*root
, name
);
1845 st
.name
= gfc_get_string (name
);
1846 gfc_delete_bbt (root
, &st
, compare_symtree
);
1852 /* Given a root symtree node and a name, try to find the symbol within
1853 the namespace. Returns NULL if the symbol is not found. */
1856 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1862 c
= strcmp (name
, st
->name
);
1866 st
= (c
< 0) ? st
->left
: st
->right
;
1873 /* Given a name find a user operator node, creating it if it doesn't
1874 exist. These are much simpler than symbols because they can't be
1875 ambiguous with one another. */
1878 gfc_get_uop (const char *name
)
1883 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1887 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1889 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1890 uop
->name
= gfc_get_string (name
);
1891 uop
->access
= ACCESS_UNKNOWN
;
1892 uop
->ns
= gfc_current_ns
;
1898 /* Given a name find the user operator node. Returns NULL if it does
1902 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1907 ns
= gfc_current_ns
;
1909 st
= gfc_find_symtree (ns
->uop_root
, name
);
1910 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1914 /* Remove a gfc_symbol structure and everything it points to. */
1917 gfc_free_symbol (gfc_symbol
* sym
)
1923 gfc_free_array_spec (sym
->as
);
1925 free_components (sym
->components
);
1927 gfc_free_expr (sym
->value
);
1929 gfc_free_namelist (sym
->namelist
);
1931 gfc_free_namespace (sym
->formal_ns
);
1933 gfc_free_interface (sym
->generic
);
1935 gfc_free_formal_arglist (sym
->formal
);
1941 /* Allocate and initialize a new symbol node. */
1944 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1948 p
= gfc_getmem (sizeof (gfc_symbol
));
1950 gfc_clear_ts (&p
->ts
);
1951 gfc_clear_attr (&p
->attr
);
1954 p
->declared_at
= gfc_current_locus
;
1956 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1957 gfc_internal_error ("new_symbol(): Symbol name too long");
1959 p
->name
= gfc_get_string (name
);
1964 /* Generate an error if a symbol is ambiguous. */
1967 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1970 if (st
->n
.sym
->module
)
1971 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1972 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1974 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1975 "from current program unit", name
, st
->n
.sym
->name
);
1979 /* Search for a symtree starting in the current namespace, resorting to
1980 any parent namespaces if requested by a nonzero parent_flag.
1981 Returns nonzero if the name is ambiguous. */
1984 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1985 gfc_symtree
** result
)
1990 ns
= gfc_current_ns
;
1994 st
= gfc_find_symtree (ns
->sym_root
, name
);
2000 ambiguous_symbol (name
, st
);
2019 /* Same, but returns the symbol instead. */
2022 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2023 gfc_symbol
** result
)
2028 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2033 *result
= st
->n
.sym
;
2039 /* Save symbol with the information necessary to back it out. */
2042 save_symbol_data (gfc_symbol
* sym
)
2045 if (sym
->new || sym
->old_symbol
!= NULL
)
2048 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2049 *(sym
->old_symbol
) = *sym
;
2051 sym
->tlink
= changed_syms
;
2056 /* Given a name, find a symbol, or create it if it does not exist yet
2057 in the current namespace. If the symbol is found we make sure that
2060 The integer return code indicates
2062 1 The symbol name was ambiguous
2063 2 The name meant to be established was already host associated.
2065 So if the return value is nonzero, then an error was issued. */
2068 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2073 /* This doesn't usually happen during resolution. */
2075 ns
= gfc_current_ns
;
2077 /* Try to find the symbol in ns. */
2078 st
= gfc_find_symtree (ns
->sym_root
, name
);
2082 /* If not there, create a new symbol. */
2083 p
= gfc_new_symbol (name
, ns
);
2085 /* Add to the list of tentative symbols. */
2086 p
->old_symbol
= NULL
;
2087 p
->tlink
= changed_syms
;
2092 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2099 /* Make sure the existing symbol is OK. */
2102 ambiguous_symbol (name
, st
);
2108 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2110 /* Symbol is from another namespace. */
2111 gfc_error ("Symbol '%s' at %C has already been host associated",
2118 /* Copy in case this symbol is changed. */
2119 save_symbol_data (p
);
2128 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2134 i
= gfc_get_sym_tree (name
, ns
, &st
);
2139 *result
= st
->n
.sym
;
2146 /* Subroutine that searches for a symbol, creating it if it doesn't
2147 exist, but tries to host-associate the symbol if possible. */
2150 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2155 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2158 save_symbol_data (st
->n
.sym
);
2164 if (gfc_current_ns
->parent
!= NULL
)
2166 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2177 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2182 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2187 i
= gfc_get_ha_sym_tree (name
, &st
);
2190 *result
= st
->n
.sym
;
2197 /* Return true if both symbols could refer to the same data object. Does
2198 not take account of aliasing due to equivalence statements. */
2201 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2203 /* Aliasing isn't possible if the symbols have different base types. */
2204 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2207 /* Pointers can point to other pointers, target objects and allocatable
2208 objects. Two allocatable objects cannot share the same storage. */
2209 if (lsym
->attr
.pointer
2210 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2212 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2214 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2221 /* Undoes all the changes made to symbols in the current statement.
2222 This subroutine is made simpler due to the fact that attributes are
2223 never removed once added. */
2226 gfc_undo_symbols (void)
2228 gfc_symbol
*p
, *q
, *old
;
2230 for (p
= changed_syms
; p
; p
= q
)
2236 /* Symbol was new. */
2237 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2241 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2243 gfc_free_symbol (p
);
2247 /* Restore previous state of symbol. Just copy simple stuff. */
2249 old
= p
->old_symbol
;
2251 p
->ts
.type
= old
->ts
.type
;
2252 p
->ts
.kind
= old
->ts
.kind
;
2254 p
->attr
= old
->attr
;
2256 if (p
->value
!= old
->value
)
2258 gfc_free_expr (old
->value
);
2262 if (p
->as
!= old
->as
)
2265 gfc_free_array_spec (p
->as
);
2269 p
->generic
= old
->generic
;
2270 p
->component_access
= old
->component_access
;
2272 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2274 gfc_free_namelist (p
->namelist
);
2280 if (p
->namelist_tail
!= old
->namelist_tail
)
2282 gfc_free_namelist (old
->namelist_tail
);
2283 old
->namelist_tail
->next
= NULL
;
2287 p
->namelist_tail
= old
->namelist_tail
;
2289 if (p
->formal
!= old
->formal
)
2291 gfc_free_formal_arglist (p
->formal
);
2292 p
->formal
= old
->formal
;
2295 gfc_free (p
->old_symbol
);
2296 p
->old_symbol
= NULL
;
2300 changed_syms
= NULL
;
2304 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2305 components of old_symbol that might need deallocation are the "allocatables"
2306 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2307 namelist_tail. In case these differ between old_symbol and sym, it's just
2308 because sym->namelist has gotten a few more items. */
2311 free_old_symbol (gfc_symbol
* sym
)
2313 if (sym
->old_symbol
== NULL
)
2316 if (sym
->old_symbol
->as
!= sym
->as
)
2317 gfc_free_array_spec (sym
->old_symbol
->as
);
2319 if (sym
->old_symbol
->value
!= sym
->value
)
2320 gfc_free_expr (sym
->old_symbol
->value
);
2322 if (sym
->old_symbol
->formal
!= sym
->formal
)
2323 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2325 gfc_free (sym
->old_symbol
);
2326 sym
->old_symbol
= NULL
;
2330 /* Makes the changes made in the current statement permanent-- gets
2331 rid of undo information. */
2334 gfc_commit_symbols (void)
2338 for (p
= changed_syms
; p
; p
= q
)
2345 free_old_symbol (p
);
2347 changed_syms
= NULL
;
2351 /* Makes the changes made in one symbol permanent -- gets rid of undo
2355 gfc_commit_symbol (gfc_symbol
* sym
)
2359 if (changed_syms
== sym
)
2360 changed_syms
= sym
->tlink
;
2363 for (p
= changed_syms
; p
; p
= p
->tlink
)
2364 if (p
->tlink
== sym
)
2366 p
->tlink
= sym
->tlink
;
2375 free_old_symbol (sym
);
2379 /* Recursive function that deletes an entire tree and all the common
2380 head structures it points to. */
2383 free_common_tree (gfc_symtree
* common_tree
)
2385 if (common_tree
== NULL
)
2388 free_common_tree (common_tree
->left
);
2389 free_common_tree (common_tree
->right
);
2391 gfc_free (common_tree
);
2395 /* Recursive function that deletes an entire tree and all the user
2396 operator nodes that it contains. */
2399 free_uop_tree (gfc_symtree
* uop_tree
)
2402 if (uop_tree
== NULL
)
2405 free_uop_tree (uop_tree
->left
);
2406 free_uop_tree (uop_tree
->right
);
2408 gfc_free_interface (uop_tree
->n
.uop
->operator);
2410 gfc_free (uop_tree
->n
.uop
);
2411 gfc_free (uop_tree
);
2415 /* Recursive function that deletes an entire tree and all the symbols
2416 that it contains. */
2419 free_sym_tree (gfc_symtree
* sym_tree
)
2424 if (sym_tree
== NULL
)
2427 free_sym_tree (sym_tree
->left
);
2428 free_sym_tree (sym_tree
->right
);
2430 sym
= sym_tree
->n
.sym
;
2434 gfc_internal_error ("free_sym_tree(): Negative refs");
2436 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2438 /* As formal_ns contains a reference to sym, delete formal_ns just
2439 before the deletion of sym. */
2440 ns
= sym
->formal_ns
;
2441 sym
->formal_ns
= NULL
;
2442 gfc_free_namespace (ns
);
2444 else if (sym
->refs
== 0)
2446 /* Go ahead and delete the symbol. */
2447 gfc_free_symbol (sym
);
2450 gfc_free (sym_tree
);
2454 /* Free a derived type list. */
2457 gfc_free_dt_list (gfc_dt_list
* dt
)
2469 /* Free the gfc_equiv_info's. */
2472 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2476 gfc_free_equiv_infos (s
->next
);
2481 /* Free the gfc_equiv_lists. */
2484 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2488 gfc_free_equiv_lists (l
->next
);
2489 gfc_free_equiv_infos (l
->equiv
);
2494 /* Free a namespace structure and everything below it. Interface
2495 lists associated with intrinsic operators are not freed. These are
2496 taken care of when a specific name is freed. */
2499 gfc_free_namespace (gfc_namespace
* ns
)
2501 gfc_charlen
*cl
, *cl2
;
2502 gfc_namespace
*p
, *q
;
2511 gcc_assert (ns
->refs
== 0);
2513 gfc_free_statements (ns
->code
);
2515 free_sym_tree (ns
->sym_root
);
2516 free_uop_tree (ns
->uop_root
);
2517 free_common_tree (ns
->common_root
);
2519 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2522 gfc_free_expr (cl
->length
);
2526 free_st_labels (ns
->st_labels
);
2528 gfc_free_equiv (ns
->equiv
);
2529 gfc_free_equiv_lists (ns
->equiv_lists
);
2531 gfc_free_dt_list (ns
->derived_types
);
2533 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2534 gfc_free_interface (ns
->operator[i
]);
2536 gfc_free_data (ns
->data
);
2540 /* Recursively free any contained namespaces. */
2546 gfc_free_namespace (q
);
2552 gfc_symbol_init_2 (void)
2555 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2560 gfc_symbol_done_2 (void)
2563 gfc_free_namespace (gfc_current_ns
);
2564 gfc_current_ns
= NULL
;
2568 /* Clear mark bits from symbol nodes associated with a symtree node. */
2571 clear_sym_mark (gfc_symtree
* st
)
2574 st
->n
.sym
->mark
= 0;
2578 /* Recursively traverse the symtree nodes. */
2581 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2587 gfc_traverse_symtree (st
->left
, func
);
2588 gfc_traverse_symtree (st
->right
, func
);
2593 /* Recursive namespace traversal function. */
2596 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2602 if (st
->n
.sym
->mark
== 0)
2603 (*func
) (st
->n
.sym
);
2604 st
->n
.sym
->mark
= 1;
2606 traverse_ns (st
->left
, func
);
2607 traverse_ns (st
->right
, func
);
2611 /* Call a given function for all symbols in the namespace. We take
2612 care that each gfc_symbol node is called exactly once. */
2615 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2618 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2620 traverse_ns (ns
->sym_root
, func
);
2624 /* Return TRUE if the symbol is an automatic variable. */
2626 gfc_is_var_automatic (gfc_symbol
* sym
)
2628 /* Pointer and allocatable variables are never automatic. */
2629 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2631 /* Check for arrays with non-constant size. */
2632 if (sym
->attr
.dimension
&& sym
->as
2633 && !gfc_is_compile_time_shape (sym
->as
))
2635 /* Check for non-constant length character variables. */
2636 if (sym
->ts
.type
== BT_CHARACTER
2638 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2643 /* Given a symbol, mark it as SAVEd if it is allowed. */
2646 save_symbol (gfc_symbol
* sym
)
2649 if (sym
->attr
.use_assoc
)
2652 if (sym
->attr
.in_common
2654 || sym
->attr
.flavor
!= FL_VARIABLE
)
2656 /* Automatic objects are not saved. */
2657 if (gfc_is_var_automatic (sym
))
2659 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2663 /* Mark those symbols which can be SAVEd as such. */
2666 gfc_save_all (gfc_namespace
* ns
)
2669 gfc_traverse_ns (ns
, save_symbol
);
2674 /* Make sure that no changes to symbols are pending. */
2677 gfc_symbol_state(void) {
2679 if (changed_syms
!= NULL
)
2680 gfc_internal_error("Symbol changes still pending!");
2685 /************** Global symbol handling ************/
2688 /* Search a tree for the global symbol. */
2691 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2697 if (strcmp (symbol
->name
, name
) == 0)
2700 s
= gfc_find_gsymbol (symbol
->left
, name
);
2704 s
= gfc_find_gsymbol (symbol
->right
, name
);
2712 /* Compare two global symbols. Used for managing the BB tree. */
2715 gsym_compare (void * _s1
, void * _s2
)
2717 gfc_gsymbol
*s1
, *s2
;
2719 s1
= (gfc_gsymbol
*)_s1
;
2720 s2
= (gfc_gsymbol
*)_s2
;
2721 return strcmp(s1
->name
, s2
->name
);
2725 /* Get a global symbol, creating it if it doesn't exist. */
2728 gfc_get_gsymbol (const char *name
)
2732 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2736 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2737 s
->type
= GSYM_UNKNOWN
;
2738 s
->name
= gfc_get_string (name
);
2740 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);