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
, threadprivate
);
323 conf (pointer
, target
);
324 conf (pointer
, external
);
325 conf (pointer
, intrinsic
);
326 conf (pointer
, elemental
);
327 conf (allocatable
, elemental
);
329 conf (target
, external
);
330 conf (target
, intrinsic
);
331 conf (external
, dimension
); /* See Fortran 95's R504. */
333 conf (external
, intrinsic
);
335 if (attr
->if_source
|| attr
->contained
)
337 conf (external
, subroutine
);
338 conf (external
, function
);
341 conf (allocatable
, pointer
);
342 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
343 conf_std (allocatable
, function
, GFC_STD_F2003
);
344 conf_std (allocatable
, result
, GFC_STD_F2003
);
345 conf (elemental
, recursive
);
347 conf (in_common
, dummy
);
348 conf (in_common
, allocatable
);
349 conf (in_common
, result
);
350 conf (in_common
, save
);
353 conf (dummy
, result
);
355 conf (in_equivalence
, use_assoc
);
356 conf (in_equivalence
, dummy
);
357 conf (in_equivalence
, target
);
358 conf (in_equivalence
, pointer
);
359 conf (in_equivalence
, function
);
360 conf (in_equivalence
, result
);
361 conf (in_equivalence
, entry
);
362 conf (in_equivalence
, allocatable
);
363 conf (in_equivalence
, threadprivate
);
365 conf (in_namelist
, pointer
);
366 conf (in_namelist
, allocatable
);
368 conf (entry
, result
);
370 conf (function
, subroutine
);
372 /* Cray pointer/pointee conflicts. */
373 conf (cray_pointer
, cray_pointee
);
374 conf (cray_pointer
, dimension
);
375 conf (cray_pointer
, pointer
);
376 conf (cray_pointer
, target
);
377 conf (cray_pointer
, allocatable
);
378 conf (cray_pointer
, external
);
379 conf (cray_pointer
, intrinsic
);
380 conf (cray_pointer
, in_namelist
);
381 conf (cray_pointer
, function
);
382 conf (cray_pointer
, subroutine
);
383 conf (cray_pointer
, entry
);
385 conf (cray_pointee
, allocatable
);
386 conf (cray_pointee
, intent
);
387 conf (cray_pointee
, optional
);
388 conf (cray_pointee
, dummy
);
389 conf (cray_pointee
, target
);
390 conf (cray_pointee
, intrinsic
);
391 conf (cray_pointee
, pointer
);
392 conf (cray_pointee
, entry
);
393 conf (cray_pointee
, in_common
);
394 conf (cray_pointee
, in_equivalence
);
395 conf (cray_pointee
, threadprivate
);
398 conf (data
, function
);
400 conf (data
, allocatable
);
401 conf (data
, use_assoc
);
403 conf (volatile_
, intrinsic
)
404 conf (volatile_
, external
)
406 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
413 a1
= gfc_code2string (flavors
, attr
->flavor
);
415 if (attr
->in_namelist
416 && attr
->flavor
!= FL_VARIABLE
417 && attr
->flavor
!= FL_UNKNOWN
)
424 switch (attr
->flavor
)
442 conf2 (threadprivate
);
452 if (attr
->subroutine
)
461 conf2(threadprivate
);
466 case PROC_ST_FUNCTION
:
479 conf2 (threadprivate
);
500 conf2 (threadprivate
);
502 if (attr
->intent
!= INTENT_UNKNOWN
)
523 conf2 (threadprivate
);
534 gfc_error ("%s attribute conflicts with %s attribute at %L",
537 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
538 a1
, a2
, name
, where
);
545 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
546 "conflicts with %s attribute at %L", a1
, a2
,
551 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
552 "conflicts with %s attribute in '%s' at %L",
553 a1
, a2
, name
, where
);
562 /* Mark a symbol as referenced. */
565 gfc_set_sym_referenced (gfc_symbol
* sym
)
567 if (sym
->attr
.referenced
)
570 sym
->attr
.referenced
= 1;
572 /* Remember which order dummy variables are accessed in. */
574 sym
->dummy_order
= next_dummy_order
++;
578 /* Common subroutine called by attribute changing subroutines in order
579 to prevent them from changing a symbol that has been
580 use-associated. Returns zero if it is OK to change the symbol,
584 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
587 if (attr
->use_assoc
== 0)
591 where
= &gfc_current_locus
;
594 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
597 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
604 /* Generate an error because of a duplicate attribute. */
607 duplicate_attr (const char *attr
, locus
* where
)
611 where
= &gfc_current_locus
;
613 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
616 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
619 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
621 if (check_used (attr
, NULL
, where
))
624 return check_conflict (attr
, NULL
, where
);
628 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
631 if (check_used (attr
, NULL
, where
))
634 if (attr
->allocatable
)
636 duplicate_attr ("ALLOCATABLE", where
);
640 attr
->allocatable
= 1;
641 return check_conflict (attr
, NULL
, where
);
646 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
649 if (check_used (attr
, name
, where
))
654 duplicate_attr ("DIMENSION", where
);
659 return check_conflict (attr
, name
, where
);
664 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
667 if (check_used (attr
, NULL
, where
))
672 duplicate_attr ("EXTERNAL", where
);
678 return check_conflict (attr
, NULL
, where
);
683 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
686 if (check_used (attr
, NULL
, where
))
691 duplicate_attr ("INTRINSIC", where
);
697 return check_conflict (attr
, NULL
, where
);
702 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
705 if (check_used (attr
, NULL
, where
))
710 duplicate_attr ("OPTIONAL", where
);
715 return check_conflict (attr
, NULL
, where
);
720 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
723 if (check_used (attr
, NULL
, where
))
727 return check_conflict (attr
, NULL
, where
);
732 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
735 if (check_used (attr
, NULL
, where
))
738 attr
->cray_pointer
= 1;
739 return check_conflict (attr
, NULL
, where
);
744 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
747 if (check_used (attr
, NULL
, where
))
750 if (attr
->cray_pointee
)
752 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
753 " statements.", where
);
757 attr
->cray_pointee
= 1;
758 return check_conflict (attr
, NULL
, where
);
763 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
766 if (check_used (attr
, name
, where
))
770 return check_conflict (attr
, name
, where
);
775 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
778 if (check_used (attr
, name
, where
))
784 ("SAVE attribute at %L cannot be specified in a PURE procedure",
791 if (gfc_notify_std (GFC_STD_LEGACY
,
792 "Duplicate SAVE attribute specified at %L",
799 return check_conflict (attr
, name
, where
);
803 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
806 if (check_used (attr
, name
, where
))
811 if (gfc_notify_std (GFC_STD_LEGACY
,
812 "Duplicate VOLATILE attribute specified at %L",
819 return check_conflict (attr
, name
, where
);
824 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
826 if (check_used (attr
, name
, where
))
829 if (attr
->threadprivate
)
831 duplicate_attr ("THREADPRIVATE", where
);
835 attr
->threadprivate
= 1;
836 return check_conflict (attr
, name
, where
);
841 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
844 if (check_used (attr
, NULL
, where
))
849 duplicate_attr ("TARGET", where
);
854 return check_conflict (attr
, NULL
, where
);
859 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
862 if (check_used (attr
, name
, where
))
865 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
867 return check_conflict (attr
, name
, where
);
872 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
875 if (check_used (attr
, name
, where
))
878 /* Duplicate attribute already checked for. */
880 if (check_conflict (attr
, name
, where
) == FAILURE
)
883 if (attr
->flavor
== FL_VARIABLE
)
886 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
890 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
893 /* Duplicate attribute already checked for. */
894 attr
->in_equivalence
= 1;
895 if (check_conflict (attr
, name
, where
) == FAILURE
)
898 if (attr
->flavor
== FL_VARIABLE
)
901 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
906 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
909 if (check_used (attr
, name
, where
))
913 return check_conflict (attr
, name
, where
);
918 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
922 attr
->in_namelist
= 1;
923 return check_conflict (attr
, name
, where
);
928 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
931 if (check_used (attr
, name
, where
))
935 return check_conflict (attr
, name
, where
);
940 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
943 if (check_used (attr
, NULL
, where
))
947 return check_conflict (attr
, NULL
, where
);
952 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
955 if (check_used (attr
, NULL
, where
))
959 return check_conflict (attr
, NULL
, where
);
964 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
967 if (check_used (attr
, NULL
, where
))
971 return check_conflict (attr
, NULL
, where
);
976 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
979 if (check_used (attr
, name
, where
))
984 duplicate_attr ("ENTRY", where
);
989 return check_conflict (attr
, name
, where
);
994 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
997 if (attr
->flavor
!= FL_PROCEDURE
998 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1002 return check_conflict (attr
, name
, where
);
1007 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1010 if (attr
->flavor
!= FL_PROCEDURE
1011 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1014 attr
->subroutine
= 1;
1015 return check_conflict (attr
, name
, where
);
1020 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1023 if (attr
->flavor
!= FL_PROCEDURE
1024 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1028 return check_conflict (attr
, name
, where
);
1032 /* Flavors are special because some flavors are not what Fortran
1033 considers attributes and can be reaffirmed multiple times. */
1036 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1040 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1041 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1042 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1045 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1048 if (attr
->flavor
!= FL_UNKNOWN
)
1051 where
= &gfc_current_locus
;
1053 gfc_error ("%s attribute conflicts with %s attribute at %L",
1054 gfc_code2string (flavors
, attr
->flavor
),
1055 gfc_code2string (flavors
, f
), where
);
1062 return check_conflict (attr
, name
, where
);
1067 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1068 const char *name
, locus
* where
)
1071 if (check_used (attr
, name
, where
))
1074 if (attr
->flavor
!= FL_PROCEDURE
1075 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1079 where
= &gfc_current_locus
;
1081 if (attr
->proc
!= PROC_UNKNOWN
)
1083 gfc_error ("%s procedure at %L is already declared as %s procedure",
1084 gfc_code2string (procedures
, t
), where
,
1085 gfc_code2string (procedures
, attr
->proc
));
1092 /* Statement functions are always scalar and functions. */
1093 if (t
== PROC_ST_FUNCTION
1094 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1095 || attr
->dimension
))
1098 return check_conflict (attr
, name
, where
);
1103 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1106 if (check_used (attr
, NULL
, where
))
1109 if (attr
->intent
== INTENT_UNKNOWN
)
1111 attr
->intent
= intent
;
1112 return check_conflict (attr
, NULL
, where
);
1116 where
= &gfc_current_locus
;
1118 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1119 gfc_intent_string (attr
->intent
),
1120 gfc_intent_string (intent
), where
);
1126 /* No checks for use-association in public and private statements. */
1129 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1130 const char *name
, locus
* where
)
1133 if (attr
->access
== ACCESS_UNKNOWN
)
1135 attr
->access
= access
;
1136 return check_conflict (attr
, name
, where
);
1140 where
= &gfc_current_locus
;
1141 gfc_error ("ACCESS specification at %L was already specified", where
);
1148 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1149 gfc_formal_arglist
* formal
, locus
* where
)
1152 if (check_used (&sym
->attr
, sym
->name
, where
))
1156 where
= &gfc_current_locus
;
1158 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1159 && sym
->attr
.if_source
!= IFSRC_DECL
)
1161 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1166 sym
->formal
= formal
;
1167 sym
->attr
.if_source
= source
;
1173 /* Add a type to a symbol. */
1176 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1181 where
= &gfc_current_locus
;
1183 if (sym
->ts
.type
!= BT_UNKNOWN
)
1185 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1186 if (!(sym
->ts
.type
== ts
->type
1187 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1188 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1191 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1194 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1195 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1199 flavor
= sym
->attr
.flavor
;
1201 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1202 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1203 && sym
->attr
.subroutine
)
1204 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1206 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1215 /* Clears all attributes. */
1218 gfc_clear_attr (symbol_attribute
* attr
)
1220 memset (attr
, 0, sizeof(symbol_attribute
));
1224 /* Check for missing attributes in the new symbol. Currently does
1225 nothing, but it's not clear that it is unnecessary yet. */
1228 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1229 locus
* where ATTRIBUTE_UNUSED
)
1236 /* Copy an attribute to a symbol attribute, bit by bit. Some
1237 attributes have a lot of side-effects but cannot be present given
1238 where we are called from, so we ignore some bits. */
1241 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1244 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1247 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1249 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1251 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1253 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1255 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1257 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1259 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1261 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1263 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1268 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1271 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1274 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1276 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1278 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1281 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1283 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1285 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1287 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1290 if (src
->flavor
!= FL_UNKNOWN
1291 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1294 if (src
->intent
!= INTENT_UNKNOWN
1295 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1298 if (src
->access
!= ACCESS_UNKNOWN
1299 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1302 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1305 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1307 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1310 /* The subroutines that set these bits also cause flavors to be set,
1311 and that has already happened in the original, so don't let it
1316 dest
->intrinsic
= 1;
1325 /************** Component name management ************/
1327 /* Component names of a derived type form their own little namespaces
1328 that are separate from all other spaces. The space is composed of
1329 a singly linked list of gfc_component structures whose head is
1330 located in the parent symbol. */
1333 /* Add a component name to a symbol. The call fails if the name is
1334 already present. On success, the component pointer is modified to
1335 point to the additional component structure. */
1338 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1340 gfc_component
*p
, *tail
;
1344 for (p
= sym
->components
; p
; p
= p
->next
)
1346 if (strcmp (p
->name
, name
) == 0)
1348 gfc_error ("Component '%s' at %C already declared at %L",
1356 /* Allocate a new component. */
1357 p
= gfc_get_component ();
1360 sym
->components
= p
;
1364 p
->name
= gfc_get_string (name
);
1365 p
->loc
= gfc_current_locus
;
1372 /* Recursive function to switch derived types of all symbol in a
1376 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1384 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1385 sym
->ts
.derived
= to
;
1387 switch_types (st
->left
, from
, to
);
1388 switch_types (st
->right
, from
, to
);
1392 /* This subroutine is called when a derived type is used in order to
1393 make the final determination about which version to use. The
1394 standard requires that a type be defined before it is 'used', but
1395 such types can appear in IMPLICIT statements before the actual
1396 definition. 'Using' in this context means declaring a variable to
1397 be that type or using the type constructor.
1399 If a type is used and the components haven't been defined, then we
1400 have to have a derived type in a parent unit. We find the node in
1401 the other namespace and point the symtree node in this namespace to
1402 that node. Further reference to this name point to the correct
1403 node. If we can't find the node in a parent namespace, then we have
1406 This subroutine takes a pointer to a symbol node and returns a
1407 pointer to the translated node or NULL for an error. Usually there
1408 is no translation and we return the node we were passed. */
1411 gfc_use_derived (gfc_symbol
* sym
)
1418 if (sym
->components
!= NULL
)
1419 return sym
; /* Already defined. */
1421 if (sym
->ns
->parent
== NULL
)
1424 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1426 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1430 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1433 /* Get rid of symbol sym, translating all references to s. */
1434 for (i
= 0; i
< GFC_LETTERS
; i
++)
1436 t
= &sym
->ns
->default_type
[i
];
1437 if (t
->derived
== sym
)
1441 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1446 /* Unlink from list of modified symbols. */
1447 gfc_commit_symbol (sym
);
1449 switch_types (sym
->ns
->sym_root
, sym
, s
);
1451 /* TODO: Also have to replace sym -> s in other lists like
1452 namelists, common lists and interface lists. */
1453 gfc_free_symbol (sym
);
1458 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1464 /* Given a derived type node and a component name, try to locate the
1465 component structure. Returns the NULL pointer if the component is
1466 not found or the components are private. */
1469 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1476 sym
= gfc_use_derived (sym
);
1481 for (p
= sym
->components
; p
; p
= p
->next
)
1482 if (strcmp (p
->name
, name
) == 0)
1486 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1490 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1492 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1502 /* Given a symbol, free all of the component structures and everything
1506 free_components (gfc_component
* p
)
1514 gfc_free_array_spec (p
->as
);
1515 gfc_free_expr (p
->initializer
);
1522 /* Set component attributes from a standard symbol attribute
1526 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1529 c
->dimension
= attr
->dimension
;
1530 c
->pointer
= attr
->pointer
;
1531 c
->allocatable
= attr
->allocatable
;
1535 /* Get a standard symbol attribute structure given the component
1539 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1542 gfc_clear_attr (attr
);
1543 attr
->dimension
= c
->dimension
;
1544 attr
->pointer
= c
->pointer
;
1545 attr
->allocatable
= c
->allocatable
;
1549 /******************** Statement label management ********************/
1551 /* Comparison function for statement labels, used for managing the
1555 compare_st_labels (void * a1
, void * b1
)
1557 int a
= ((gfc_st_label
*)a1
)->value
;
1558 int b
= ((gfc_st_label
*)b1
)->value
;
1564 /* Free a single gfc_st_label structure, making sure the tree is not
1565 messed up. This function is called only when some parse error
1569 gfc_free_st_label (gfc_st_label
* label
)
1574 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1576 if (label
->format
!= NULL
)
1577 gfc_free_expr (label
->format
);
1582 /* Free a whole tree of gfc_st_label structures. */
1585 free_st_labels (gfc_st_label
* label
)
1590 free_st_labels (label
->left
);
1591 free_st_labels (label
->right
);
1593 if (label
->format
!= NULL
)
1594 gfc_free_expr (label
->format
);
1599 /* Given a label number, search for and return a pointer to the label
1600 structure, creating it if it does not exist. */
1603 gfc_get_st_label (int labelno
)
1607 /* First see if the label is already in this namespace. */
1608 lp
= gfc_current_ns
->st_labels
;
1611 if (lp
->value
== labelno
)
1614 if (lp
->value
< labelno
)
1620 lp
= gfc_getmem (sizeof (gfc_st_label
));
1622 lp
->value
= labelno
;
1623 lp
->defined
= ST_LABEL_UNKNOWN
;
1624 lp
->referenced
= ST_LABEL_UNKNOWN
;
1626 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1632 /* Called when a statement with a statement label is about to be
1633 accepted. We add the label to the list of the current namespace,
1634 making sure it hasn't been defined previously and referenced
1638 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1642 labelno
= lp
->value
;
1644 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1645 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1646 &lp
->where
, label_locus
);
1649 lp
->where
= *label_locus
;
1653 case ST_LABEL_FORMAT
:
1654 if (lp
->referenced
== ST_LABEL_TARGET
)
1655 gfc_error ("Label %d at %C already referenced as branch target",
1658 lp
->defined
= ST_LABEL_FORMAT
;
1662 case ST_LABEL_TARGET
:
1663 if (lp
->referenced
== ST_LABEL_FORMAT
)
1664 gfc_error ("Label %d at %C already referenced as a format label",
1667 lp
->defined
= ST_LABEL_TARGET
;
1672 lp
->defined
= ST_LABEL_BAD_TARGET
;
1673 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1679 /* Reference a label. Given a label and its type, see if that
1680 reference is consistent with what is known about that label,
1681 updating the unknown state. Returns FAILURE if something goes
1685 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1687 gfc_sl_type label_type
;
1694 labelno
= lp
->value
;
1696 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1697 label_type
= lp
->defined
;
1700 label_type
= lp
->referenced
;
1701 lp
->where
= gfc_current_locus
;
1704 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1706 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1711 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1712 && type
== ST_LABEL_FORMAT
)
1714 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1719 lp
->referenced
= type
;
1727 /************** Symbol table management subroutines ****************/
1729 /* Basic details: Fortran 95 requires a potentially unlimited number
1730 of distinct namespaces when compiling a program unit. This case
1731 occurs during a compilation of internal subprograms because all of
1732 the internal subprograms must be read before we can start
1733 generating code for the host.
1735 Given the tricky nature of the Fortran grammar, we must be able to
1736 undo changes made to a symbol table if the current interpretation
1737 of a statement is found to be incorrect. Whenever a symbol is
1738 looked up, we make a copy of it and link to it. All of these
1739 symbols are kept in a singly linked list so that we can commit or
1740 undo the changes at a later time.
1742 A symtree may point to a symbol node outside of its namespace. In
1743 this case, that symbol has been used as a host associated variable
1744 at some previous time. */
1746 /* Allocate a new namespace structure. Copies the implicit types from
1747 PARENT if PARENT_TYPES is set. */
1750 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1754 gfc_intrinsic_op in
;
1757 ns
= gfc_getmem (sizeof (gfc_namespace
));
1758 ns
->sym_root
= NULL
;
1759 ns
->uop_root
= NULL
;
1760 ns
->default_access
= ACCESS_UNKNOWN
;
1761 ns
->parent
= parent
;
1763 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1764 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1766 /* Initialize default implicit types. */
1767 for (i
= 'a'; i
<= 'z'; i
++)
1769 ns
->set_flag
[i
- 'a'] = 0;
1770 ts
= &ns
->default_type
[i
- 'a'];
1772 if (parent_types
&& ns
->parent
!= NULL
)
1774 /* Copy parent settings */
1775 *ts
= ns
->parent
->default_type
[i
- 'a'];
1779 if (gfc_option
.flag_implicit_none
!= 0)
1785 if ('i' <= i
&& i
<= 'n')
1787 ts
->type
= BT_INTEGER
;
1788 ts
->kind
= gfc_default_integer_kind
;
1793 ts
->kind
= gfc_default_real_kind
;
1803 /* Comparison function for symtree nodes. */
1806 compare_symtree (void * _st1
, void * _st2
)
1808 gfc_symtree
*st1
, *st2
;
1810 st1
= (gfc_symtree
*) _st1
;
1811 st2
= (gfc_symtree
*) _st2
;
1813 return strcmp (st1
->name
, st2
->name
);
1817 /* Allocate a new symtree node and associate it with the new symbol. */
1820 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1824 st
= gfc_getmem (sizeof (gfc_symtree
));
1825 st
->name
= gfc_get_string (name
);
1827 gfc_insert_bbt (root
, st
, compare_symtree
);
1832 /* Delete a symbol from the tree. Does not free the symbol itself! */
1835 delete_symtree (gfc_symtree
** root
, const char *name
)
1837 gfc_symtree st
, *st0
;
1839 st0
= gfc_find_symtree (*root
, name
);
1841 st
.name
= gfc_get_string (name
);
1842 gfc_delete_bbt (root
, &st
, compare_symtree
);
1848 /* Given a root symtree node and a name, try to find the symbol within
1849 the namespace. Returns NULL if the symbol is not found. */
1852 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1858 c
= strcmp (name
, st
->name
);
1862 st
= (c
< 0) ? st
->left
: st
->right
;
1869 /* Given a name find a user operator node, creating it if it doesn't
1870 exist. These are much simpler than symbols because they can't be
1871 ambiguous with one another. */
1874 gfc_get_uop (const char *name
)
1879 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1883 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1885 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1886 uop
->name
= gfc_get_string (name
);
1887 uop
->access
= ACCESS_UNKNOWN
;
1888 uop
->ns
= gfc_current_ns
;
1894 /* Given a name find the user operator node. Returns NULL if it does
1898 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1903 ns
= gfc_current_ns
;
1905 st
= gfc_find_symtree (ns
->uop_root
, name
);
1906 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1910 /* Remove a gfc_symbol structure and everything it points to. */
1913 gfc_free_symbol (gfc_symbol
* sym
)
1919 gfc_free_array_spec (sym
->as
);
1921 free_components (sym
->components
);
1923 gfc_free_expr (sym
->value
);
1925 gfc_free_namelist (sym
->namelist
);
1927 gfc_free_namespace (sym
->formal_ns
);
1929 gfc_free_interface (sym
->generic
);
1931 gfc_free_formal_arglist (sym
->formal
);
1937 /* Allocate and initialize a new symbol node. */
1940 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1944 p
= gfc_getmem (sizeof (gfc_symbol
));
1946 gfc_clear_ts (&p
->ts
);
1947 gfc_clear_attr (&p
->attr
);
1950 p
->declared_at
= gfc_current_locus
;
1952 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1953 gfc_internal_error ("new_symbol(): Symbol name too long");
1955 p
->name
= gfc_get_string (name
);
1960 /* Generate an error if a symbol is ambiguous. */
1963 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1966 if (st
->n
.sym
->module
)
1967 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1968 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1970 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1971 "from current program unit", name
, st
->n
.sym
->name
);
1975 /* Search for a symtree starting in the current namespace, resorting to
1976 any parent namespaces if requested by a nonzero parent_flag.
1977 Returns nonzero if the name is ambiguous. */
1980 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1981 gfc_symtree
** result
)
1986 ns
= gfc_current_ns
;
1990 st
= gfc_find_symtree (ns
->sym_root
, name
);
1996 ambiguous_symbol (name
, st
);
2015 /* Same, but returns the symbol instead. */
2018 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2019 gfc_symbol
** result
)
2024 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2029 *result
= st
->n
.sym
;
2035 /* Save symbol with the information necessary to back it out. */
2038 save_symbol_data (gfc_symbol
* sym
)
2041 if (sym
->new || sym
->old_symbol
!= NULL
)
2044 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2045 *(sym
->old_symbol
) = *sym
;
2047 sym
->tlink
= changed_syms
;
2052 /* Given a name, find a symbol, or create it if it does not exist yet
2053 in the current namespace. If the symbol is found we make sure that
2056 The integer return code indicates
2058 1 The symbol name was ambiguous
2059 2 The name meant to be established was already host associated.
2061 So if the return value is nonzero, then an error was issued. */
2064 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2069 /* This doesn't usually happen during resolution. */
2071 ns
= gfc_current_ns
;
2073 /* Try to find the symbol in ns. */
2074 st
= gfc_find_symtree (ns
->sym_root
, name
);
2078 /* If not there, create a new symbol. */
2079 p
= gfc_new_symbol (name
, ns
);
2081 /* Add to the list of tentative symbols. */
2082 p
->old_symbol
= NULL
;
2083 p
->tlink
= changed_syms
;
2088 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2095 /* Make sure the existing symbol is OK. */
2098 ambiguous_symbol (name
, st
);
2104 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2106 /* Symbol is from another namespace. */
2107 gfc_error ("Symbol '%s' at %C has already been host associated",
2114 /* Copy in case this symbol is changed. */
2115 save_symbol_data (p
);
2124 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2130 i
= gfc_get_sym_tree (name
, ns
, &st
);
2135 *result
= st
->n
.sym
;
2142 /* Subroutine that searches for a symbol, creating it if it doesn't
2143 exist, but tries to host-associate the symbol if possible. */
2146 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2151 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2154 save_symbol_data (st
->n
.sym
);
2160 if (gfc_current_ns
->parent
!= NULL
)
2162 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2173 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2178 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2183 i
= gfc_get_ha_sym_tree (name
, &st
);
2186 *result
= st
->n
.sym
;
2193 /* Return true if both symbols could refer to the same data object. Does
2194 not take account of aliasing due to equivalence statements. */
2197 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2199 /* Aliasing isn't possible if the symbols have different base types. */
2200 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2203 /* Pointers can point to other pointers, target objects and allocatable
2204 objects. Two allocatable objects cannot share the same storage. */
2205 if (lsym
->attr
.pointer
2206 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2208 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2210 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2217 /* Undoes all the changes made to symbols in the current statement.
2218 This subroutine is made simpler due to the fact that attributes are
2219 never removed once added. */
2222 gfc_undo_symbols (void)
2224 gfc_symbol
*p
, *q
, *old
;
2226 for (p
= changed_syms
; p
; p
= q
)
2232 /* Symbol was new. */
2233 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2237 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2239 gfc_free_symbol (p
);
2243 /* Restore previous state of symbol. Just copy simple stuff. */
2245 old
= p
->old_symbol
;
2247 p
->ts
.type
= old
->ts
.type
;
2248 p
->ts
.kind
= old
->ts
.kind
;
2250 p
->attr
= old
->attr
;
2252 if (p
->value
!= old
->value
)
2254 gfc_free_expr (old
->value
);
2258 if (p
->as
!= old
->as
)
2261 gfc_free_array_spec (p
->as
);
2265 p
->generic
= old
->generic
;
2266 p
->component_access
= old
->component_access
;
2268 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2270 gfc_free_namelist (p
->namelist
);
2276 if (p
->namelist_tail
!= old
->namelist_tail
)
2278 gfc_free_namelist (old
->namelist_tail
);
2279 old
->namelist_tail
->next
= NULL
;
2283 p
->namelist_tail
= old
->namelist_tail
;
2285 if (p
->formal
!= old
->formal
)
2287 gfc_free_formal_arglist (p
->formal
);
2288 p
->formal
= old
->formal
;
2291 gfc_free (p
->old_symbol
);
2292 p
->old_symbol
= NULL
;
2296 changed_syms
= NULL
;
2300 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2301 components of old_symbol that might need deallocation are the "allocatables"
2302 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2303 namelist_tail. In case these differ between old_symbol and sym, it's just
2304 because sym->namelist has gotten a few more items. */
2307 free_old_symbol (gfc_symbol
* sym
)
2309 if (sym
->old_symbol
== NULL
)
2312 if (sym
->old_symbol
->as
!= sym
->as
)
2313 gfc_free_array_spec (sym
->old_symbol
->as
);
2315 if (sym
->old_symbol
->value
!= sym
->value
)
2316 gfc_free_expr (sym
->old_symbol
->value
);
2318 if (sym
->old_symbol
->formal
!= sym
->formal
)
2319 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2321 gfc_free (sym
->old_symbol
);
2322 sym
->old_symbol
= NULL
;
2326 /* Makes the changes made in the current statement permanent-- gets
2327 rid of undo information. */
2330 gfc_commit_symbols (void)
2334 for (p
= changed_syms
; p
; p
= q
)
2341 free_old_symbol (p
);
2343 changed_syms
= NULL
;
2347 /* Makes the changes made in one symbol permanent -- gets rid of undo
2351 gfc_commit_symbol (gfc_symbol
* sym
)
2355 if (changed_syms
== sym
)
2356 changed_syms
= sym
->tlink
;
2359 for (p
= changed_syms
; p
; p
= p
->tlink
)
2360 if (p
->tlink
== sym
)
2362 p
->tlink
= sym
->tlink
;
2371 free_old_symbol (sym
);
2375 /* Recursive function that deletes an entire tree and all the common
2376 head structures it points to. */
2379 free_common_tree (gfc_symtree
* common_tree
)
2381 if (common_tree
== NULL
)
2384 free_common_tree (common_tree
->left
);
2385 free_common_tree (common_tree
->right
);
2387 gfc_free (common_tree
);
2391 /* Recursive function that deletes an entire tree and all the user
2392 operator nodes that it contains. */
2395 free_uop_tree (gfc_symtree
* uop_tree
)
2398 if (uop_tree
== NULL
)
2401 free_uop_tree (uop_tree
->left
);
2402 free_uop_tree (uop_tree
->right
);
2404 gfc_free_interface (uop_tree
->n
.uop
->operator);
2406 gfc_free (uop_tree
->n
.uop
);
2407 gfc_free (uop_tree
);
2411 /* Recursive function that deletes an entire tree and all the symbols
2412 that it contains. */
2415 free_sym_tree (gfc_symtree
* sym_tree
)
2420 if (sym_tree
== NULL
)
2423 free_sym_tree (sym_tree
->left
);
2424 free_sym_tree (sym_tree
->right
);
2426 sym
= sym_tree
->n
.sym
;
2430 gfc_internal_error ("free_sym_tree(): Negative refs");
2432 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2434 /* As formal_ns contains a reference to sym, delete formal_ns just
2435 before the deletion of sym. */
2436 ns
= sym
->formal_ns
;
2437 sym
->formal_ns
= NULL
;
2438 gfc_free_namespace (ns
);
2440 else if (sym
->refs
== 0)
2442 /* Go ahead and delete the symbol. */
2443 gfc_free_symbol (sym
);
2446 gfc_free (sym_tree
);
2450 /* Free a derived type list. */
2453 gfc_free_dt_list (gfc_dt_list
* dt
)
2465 /* Free the gfc_equiv_info's. */
2468 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2472 gfc_free_equiv_infos (s
->next
);
2477 /* Free the gfc_equiv_lists. */
2480 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2484 gfc_free_equiv_lists (l
->next
);
2485 gfc_free_equiv_infos (l
->equiv
);
2490 /* Free a namespace structure and everything below it. Interface
2491 lists associated with intrinsic operators are not freed. These are
2492 taken care of when a specific name is freed. */
2495 gfc_free_namespace (gfc_namespace
* ns
)
2497 gfc_charlen
*cl
, *cl2
;
2498 gfc_namespace
*p
, *q
;
2507 gcc_assert (ns
->refs
== 0);
2509 gfc_free_statements (ns
->code
);
2511 free_sym_tree (ns
->sym_root
);
2512 free_uop_tree (ns
->uop_root
);
2513 free_common_tree (ns
->common_root
);
2515 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2518 gfc_free_expr (cl
->length
);
2522 free_st_labels (ns
->st_labels
);
2524 gfc_free_equiv (ns
->equiv
);
2525 gfc_free_equiv_lists (ns
->equiv_lists
);
2527 gfc_free_dt_list (ns
->derived_types
);
2529 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2530 gfc_free_interface (ns
->operator[i
]);
2532 gfc_free_data (ns
->data
);
2536 /* Recursively free any contained namespaces. */
2542 gfc_free_namespace (q
);
2548 gfc_symbol_init_2 (void)
2551 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2556 gfc_symbol_done_2 (void)
2559 gfc_free_namespace (gfc_current_ns
);
2560 gfc_current_ns
= NULL
;
2564 /* Clear mark bits from symbol nodes associated with a symtree node. */
2567 clear_sym_mark (gfc_symtree
* st
)
2570 st
->n
.sym
->mark
= 0;
2574 /* Recursively traverse the symtree nodes. */
2577 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2583 gfc_traverse_symtree (st
->left
, func
);
2584 gfc_traverse_symtree (st
->right
, func
);
2589 /* Recursive namespace traversal function. */
2592 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2598 if (st
->n
.sym
->mark
== 0)
2599 (*func
) (st
->n
.sym
);
2600 st
->n
.sym
->mark
= 1;
2602 traverse_ns (st
->left
, func
);
2603 traverse_ns (st
->right
, func
);
2607 /* Call a given function for all symbols in the namespace. We take
2608 care that each gfc_symbol node is called exactly once. */
2611 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2614 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2616 traverse_ns (ns
->sym_root
, func
);
2620 /* Return TRUE if the symbol is an automatic variable. */
2622 gfc_is_var_automatic (gfc_symbol
* sym
)
2624 /* Pointer and allocatable variables are never automatic. */
2625 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2627 /* Check for arrays with non-constant size. */
2628 if (sym
->attr
.dimension
&& sym
->as
2629 && !gfc_is_compile_time_shape (sym
->as
))
2631 /* Check for non-constant length character variables. */
2632 if (sym
->ts
.type
== BT_CHARACTER
2634 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2639 /* Given a symbol, mark it as SAVEd if it is allowed. */
2642 save_symbol (gfc_symbol
* sym
)
2645 if (sym
->attr
.use_assoc
)
2648 if (sym
->attr
.in_common
2650 || sym
->attr
.flavor
!= FL_VARIABLE
)
2652 /* Automatic objects are not saved. */
2653 if (gfc_is_var_automatic (sym
))
2655 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2659 /* Mark those symbols which can be SAVEd as such. */
2662 gfc_save_all (gfc_namespace
* ns
)
2665 gfc_traverse_ns (ns
, save_symbol
);
2670 /* Make sure that no changes to symbols are pending. */
2673 gfc_symbol_state(void) {
2675 if (changed_syms
!= NULL
)
2676 gfc_internal_error("Symbol changes still pending!");
2681 /************** Global symbol handling ************/
2684 /* Search a tree for the global symbol. */
2687 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2693 if (strcmp (symbol
->name
, name
) == 0)
2696 s
= gfc_find_gsymbol (symbol
->left
, name
);
2700 s
= gfc_find_gsymbol (symbol
->right
, name
);
2708 /* Compare two global symbols. Used for managing the BB tree. */
2711 gsym_compare (void * _s1
, void * _s2
)
2713 gfc_gsymbol
*s1
, *s2
;
2715 s1
= (gfc_gsymbol
*)_s1
;
2716 s2
= (gfc_gsymbol
*)_s2
;
2717 return strcmp(s1
->name
, s2
->name
);
2721 /* Get a global symbol, creating it if it doesn't exist. */
2724 gfc_get_gsymbol (const char *name
)
2728 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2732 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2733 s
->type
= GSYM_UNKNOWN
;
2734 s
->name
= gfc_get_string (name
);
2736 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);