1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors
[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
37 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
38 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
39 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 const mstring procedures
[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
46 minit ("MODULE-PROC", PROC_MODULE
),
47 minit ("INTERNAL-PROC", PROC_INTERNAL
),
48 minit ("DUMMY-PROC", PROC_DUMMY
),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
55 const mstring intents
[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
58 minit ("IN", INTENT_IN
),
59 minit ("OUT", INTENT_OUT
),
60 minit ("INOUT", INTENT_INOUT
),
64 const mstring access_types
[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
67 minit ("PUBLIC", ACCESS_PUBLIC
),
68 minit ("PRIVATE", ACCESS_PRIVATE
),
72 const mstring ifsrc_types
[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN
),
75 minit ("DECL", IFSRC_DECL
),
76 minit ("BODY", IFSRC_IFBODY
),
77 minit ("USAGE", IFSRC_USAGE
)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order
= 1;
87 gfc_namespace
*gfc_current_ns
;
89 gfc_gsymbol
*gfc_gsym_root
= NULL
;
91 static gfc_symbol
*changed_syms
= NULL
;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag
[GFC_LETTERS
];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 if (gfc_current_ns
->seen_implicit_none
)
111 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
115 gfc_current_ns
->seen_implicit_none
= 1;
117 for (i
= 0; i
< GFC_LETTERS
; i
++)
119 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
120 gfc_current_ns
->set_flag
[i
] = 1;
125 /* Reset the implicit range flags. */
128 gfc_clear_new_implicit (void)
132 for (i
= 0; i
< GFC_LETTERS
; i
++)
137 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
140 gfc_add_new_implicit_range (int c1
, int c2
)
147 for (i
= c1
; i
<= c2
; i
++)
151 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
163 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
164 the new implicit types back into the existing types will work. */
167 gfc_merge_new_implicit (gfc_typespec
* ts
)
171 if (gfc_current_ns
->seen_implicit_none
)
173 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
177 for (i
= 0; i
< GFC_LETTERS
; i
++)
182 if (gfc_current_ns
->set_flag
[i
])
184 gfc_error ("Letter %c already has an IMPLICIT type at %C",
188 gfc_current_ns
->default_type
[i
] = *ts
;
189 gfc_current_ns
->set_flag
[i
] = 1;
196 /* Given a symbol, return a pointer to the typespec for its default type. */
199 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
203 letter
= sym
->name
[0];
204 if (letter
< 'a' || letter
> 'z')
205 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
210 return &ns
->default_type
[letter
- 'a'];
214 /* Given a pointer to a symbol, set its type according to the first
215 letter of its name. Fails if the letter in question has no default
219 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
223 if (sym
->ts
.type
!= BT_UNKNOWN
)
224 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
226 ts
= gfc_get_default_type (sym
, ns
);
228 if (ts
->type
== BT_UNKNOWN
)
230 if (error_flag
&& !sym
->attr
.untyped
)
232 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
233 sym
->name
, &sym
->declared_at
);
234 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
241 sym
->attr
.implicit_type
= 1;
247 /******************** Symbol attribute stuff *********************/
249 /* This is a generic conflict-checker. We do this to avoid having a
250 single conflict in two places. */
252 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
253 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
254 #define conf_std(a, b, std) if (attr->a && attr->b)\
263 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
265 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
266 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
267 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
268 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
269 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
270 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
271 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
272 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
273 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
274 *cray_pointee
= "CRAY POINTEE", *data
= "DATA";
275 static const char *threadprivate
= "THREADPRIVATE";
281 where
= &gfc_current_locus
;
283 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
290 /* Check for attributes not allowed in a BLOCK DATA. */
291 if (gfc_current_state () == COMP_BLOCK_DATA
)
295 if (attr
->in_namelist
)
297 if (attr
->allocatable
)
303 if (attr
->access
== ACCESS_PRIVATE
)
305 if (attr
->access
== ACCESS_PUBLIC
)
307 if (attr
->intent
!= INTENT_UNKNOWN
)
313 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
320 conf (dummy
, threadprivate
);
321 conf (pointer
, target
);
322 conf (pointer
, external
);
323 conf (pointer
, intrinsic
);
324 conf (pointer
, elemental
);
325 conf (allocatable
, elemental
);
327 conf (target
, external
);
328 conf (target
, intrinsic
);
329 conf (external
, dimension
); /* See Fortran 95's R504. */
331 conf (external
, intrinsic
);
333 if (attr
->if_source
|| attr
->contained
)
335 conf (external
, subroutine
);
336 conf (external
, function
);
339 conf (allocatable
, pointer
);
340 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
341 conf_std (allocatable
, function
, GFC_STD_F2003
);
342 conf_std (allocatable
, result
, GFC_STD_F2003
);
343 conf (elemental
, recursive
);
345 conf (in_common
, dummy
);
346 conf (in_common
, allocatable
);
347 conf (in_common
, result
);
348 conf (in_common
, save
);
351 conf (dummy
, result
);
353 conf (in_equivalence
, use_assoc
);
354 conf (in_equivalence
, dummy
);
355 conf (in_equivalence
, target
);
356 conf (in_equivalence
, pointer
);
357 conf (in_equivalence
, function
);
358 conf (in_equivalence
, result
);
359 conf (in_equivalence
, entry
);
360 conf (in_equivalence
, allocatable
);
361 conf (in_equivalence
, threadprivate
);
363 conf (in_namelist
, pointer
);
364 conf (in_namelist
, allocatable
);
366 conf (entry
, result
);
368 conf (function
, subroutine
);
370 /* Cray pointer/pointee conflicts. */
371 conf (cray_pointer
, cray_pointee
);
372 conf (cray_pointer
, dimension
);
373 conf (cray_pointer
, pointer
);
374 conf (cray_pointer
, target
);
375 conf (cray_pointer
, allocatable
);
376 conf (cray_pointer
, external
);
377 conf (cray_pointer
, intrinsic
);
378 conf (cray_pointer
, in_namelist
);
379 conf (cray_pointer
, function
);
380 conf (cray_pointer
, subroutine
);
381 conf (cray_pointer
, entry
);
383 conf (cray_pointee
, allocatable
);
384 conf (cray_pointee
, intent
);
385 conf (cray_pointee
, optional
);
386 conf (cray_pointee
, dummy
);
387 conf (cray_pointee
, target
);
388 conf (cray_pointee
, external
);
389 conf (cray_pointee
, intrinsic
);
390 conf (cray_pointee
, pointer
);
391 conf (cray_pointee
, function
);
392 conf (cray_pointee
, subroutine
);
393 conf (cray_pointee
, entry
);
394 conf (cray_pointee
, in_common
);
395 conf (cray_pointee
, in_equivalence
);
396 conf (cray_pointee
, threadprivate
);
399 conf (data
, function
);
401 conf (data
, allocatable
);
402 conf (data
, use_assoc
);
404 a1
= gfc_code2string (flavors
, attr
->flavor
);
406 if (attr
->in_namelist
407 && attr
->flavor
!= FL_VARIABLE
408 && attr
->flavor
!= FL_UNKNOWN
)
415 switch (attr
->flavor
)
433 conf2 (threadprivate
);
443 if (attr
->subroutine
)
452 conf2(threadprivate
);
457 case PROC_ST_FUNCTION
:
470 conf2 (threadprivate
);
491 conf2 (threadprivate
);
493 if (attr
->intent
!= INTENT_UNKNOWN
)
513 conf2 (threadprivate
);
524 gfc_error ("%s attribute conflicts with %s attribute at %L",
527 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
528 a1
, a2
, name
, where
);
535 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
536 "conflicts with %s attribute at %L", a1
, a2
,
541 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
542 "conflicts with %s attribute in '%s' at %L",
543 a1
, a2
, name
, where
);
552 /* Mark a symbol as referenced. */
555 gfc_set_sym_referenced (gfc_symbol
* sym
)
557 if (sym
->attr
.referenced
)
560 sym
->attr
.referenced
= 1;
562 /* Remember which order dummy variables are accessed in. */
564 sym
->dummy_order
= next_dummy_order
++;
568 /* Common subroutine called by attribute changing subroutines in order
569 to prevent them from changing a symbol that has been
570 use-associated. Returns zero if it is OK to change the symbol,
574 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
577 if (attr
->use_assoc
== 0)
581 where
= &gfc_current_locus
;
584 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
587 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
594 /* Used to prevent changing the attributes of a symbol after it has been
595 used. This check is only done for dummy variables as only these can be
596 used in specification expressions. Applying this to all symbols causes
597 an error when we reach the body of a contained function. */
600 check_done (symbol_attribute
* attr
, locus
* where
)
603 if (!(attr
->dummy
&& attr
->referenced
))
607 where
= &gfc_current_locus
;
609 gfc_error ("Cannot change attributes of symbol at %L"
610 " after it has been used", where
);
616 /* Generate an error because of a duplicate attribute. */
619 duplicate_attr (const char *attr
, locus
* where
)
623 where
= &gfc_current_locus
;
625 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
628 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
631 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
,
632 unsigned int attr_intent
)
635 if (check_used (attr
, NULL
, where
)
636 || (attr_intent
== 0 && check_done (attr
, where
)))
639 return check_conflict (attr
, NULL
, where
);
643 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
646 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
649 if (attr
->allocatable
)
651 duplicate_attr ("ALLOCATABLE", where
);
655 attr
->allocatable
= 1;
656 return check_conflict (attr
, NULL
, where
);
661 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
664 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
669 duplicate_attr ("DIMENSION", where
);
674 return check_conflict (attr
, name
, where
);
679 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
682 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
687 duplicate_attr ("EXTERNAL", where
);
693 return check_conflict (attr
, NULL
, where
);
698 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
701 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
706 duplicate_attr ("INTRINSIC", where
);
712 return check_conflict (attr
, NULL
, where
);
717 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
720 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
725 duplicate_attr ("OPTIONAL", where
);
730 return check_conflict (attr
, NULL
, where
);
735 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
738 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
742 return check_conflict (attr
, NULL
, where
);
747 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
750 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
753 attr
->cray_pointer
= 1;
754 return check_conflict (attr
, NULL
, where
);
759 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
762 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
765 if (attr
->cray_pointee
)
767 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
768 " statements.", where
);
772 attr
->cray_pointee
= 1;
773 return check_conflict (attr
, NULL
, where
);
778 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
781 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
785 return check_conflict (attr
, name
, where
);
790 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
793 if (check_used (attr
, name
, where
))
799 ("SAVE attribute at %L cannot be specified in a PURE procedure",
806 if (gfc_notify_std (GFC_STD_LEGACY
,
807 "Duplicate SAVE attribute specified at %L",
814 return check_conflict (attr
, name
, where
);
819 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
821 if (check_used (attr
, name
, where
))
824 if (attr
->threadprivate
)
826 duplicate_attr ("THREADPRIVATE", where
);
830 attr
->threadprivate
= 1;
831 return check_conflict (attr
, name
, where
);
836 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
839 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
844 duplicate_attr ("TARGET", where
);
849 return check_conflict (attr
, NULL
, where
);
854 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
857 if (check_used (attr
, name
, where
))
860 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
862 return check_conflict (attr
, name
, where
);
867 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
870 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
873 /* Duplicate attribute already checked for. */
875 if (check_conflict (attr
, name
, where
) == FAILURE
)
878 if (attr
->flavor
== FL_VARIABLE
)
881 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
885 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
888 /* Duplicate attribute already checked for. */
889 attr
->in_equivalence
= 1;
890 if (check_conflict (attr
, name
, where
) == FAILURE
)
893 if (attr
->flavor
== FL_VARIABLE
)
896 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
901 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
904 if (check_used (attr
, name
, where
))
908 return check_conflict (attr
, name
, where
);
913 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
917 attr
->in_namelist
= 1;
918 return check_conflict (attr
, name
, where
);
923 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
926 if (check_used (attr
, name
, where
))
930 return check_conflict (attr
, name
, where
);
935 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
938 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
942 return check_conflict (attr
, NULL
, where
);
947 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
950 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
954 return check_conflict (attr
, NULL
, where
);
959 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
962 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
966 return check_conflict (attr
, NULL
, where
);
971 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
974 if (check_used (attr
, name
, where
))
979 duplicate_attr ("ENTRY", where
);
984 return check_conflict (attr
, name
, where
);
989 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
992 if (attr
->flavor
!= FL_PROCEDURE
993 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
997 return check_conflict (attr
, name
, where
);
1002 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1005 if (attr
->flavor
!= FL_PROCEDURE
1006 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1009 attr
->subroutine
= 1;
1010 return check_conflict (attr
, name
, where
);
1015 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1018 if (attr
->flavor
!= FL_PROCEDURE
1019 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1023 return check_conflict (attr
, name
, where
);
1027 /* Flavors are special because some flavors are not what Fortran
1028 considers attributes and can be reaffirmed multiple times. */
1031 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1035 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1036 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1037 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1040 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1043 if (attr
->flavor
!= FL_UNKNOWN
)
1046 where
= &gfc_current_locus
;
1048 gfc_error ("%s attribute conflicts with %s attribute at %L",
1049 gfc_code2string (flavors
, attr
->flavor
),
1050 gfc_code2string (flavors
, f
), where
);
1057 return check_conflict (attr
, name
, where
);
1062 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1063 const char *name
, locus
* where
)
1066 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1069 if (attr
->flavor
!= FL_PROCEDURE
1070 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1074 where
= &gfc_current_locus
;
1076 if (attr
->proc
!= PROC_UNKNOWN
)
1078 gfc_error ("%s procedure at %L is already declared as %s procedure",
1079 gfc_code2string (procedures
, t
), where
,
1080 gfc_code2string (procedures
, attr
->proc
));
1087 /* Statement functions are always scalar and functions. */
1088 if (t
== PROC_ST_FUNCTION
1089 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1090 || attr
->dimension
))
1093 return check_conflict (attr
, name
, where
);
1098 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1101 if (check_used (attr
, NULL
, where
))
1104 if (attr
->intent
== INTENT_UNKNOWN
)
1106 attr
->intent
= intent
;
1107 return check_conflict (attr
, NULL
, where
);
1111 where
= &gfc_current_locus
;
1113 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1114 gfc_intent_string (attr
->intent
),
1115 gfc_intent_string (intent
), where
);
1121 /* No checks for use-association in public and private statements. */
1124 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1125 const char *name
, locus
* where
)
1128 if (attr
->access
== ACCESS_UNKNOWN
)
1130 attr
->access
= access
;
1131 return check_conflict (attr
, name
, where
);
1135 where
= &gfc_current_locus
;
1136 gfc_error ("ACCESS specification at %L was already specified", where
);
1143 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1144 gfc_formal_arglist
* formal
, locus
* where
)
1147 if (check_used (&sym
->attr
, sym
->name
, where
))
1151 where
= &gfc_current_locus
;
1153 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1154 && sym
->attr
.if_source
!= IFSRC_DECL
)
1156 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1161 sym
->formal
= formal
;
1162 sym
->attr
.if_source
= source
;
1168 /* Add a type to a symbol. */
1171 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1175 /* TODO: This is legal if it is reaffirming an implicit type.
1176 if (check_done (&sym->attr, where))
1180 where
= &gfc_current_locus
;
1182 if (sym
->ts
.type
!= BT_UNKNOWN
)
1184 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1185 where
, gfc_basic_typename (sym
->ts
.type
));
1189 flavor
= sym
->attr
.flavor
;
1191 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1192 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1193 && sym
->attr
.subroutine
)
1194 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1196 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1205 /* Clears all attributes. */
1208 gfc_clear_attr (symbol_attribute
* attr
)
1210 memset (attr
, 0, sizeof(symbol_attribute
));
1214 /* Check for missing attributes in the new symbol. Currently does
1215 nothing, but it's not clear that it is unnecessary yet. */
1218 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1219 locus
* where ATTRIBUTE_UNUSED
)
1226 /* Copy an attribute to a symbol attribute, bit by bit. Some
1227 attributes have a lot of side-effects but cannot be present given
1228 where we are called from, so we ignore some bits. */
1231 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1234 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1237 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1239 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1241 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1243 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1245 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1247 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1249 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1251 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1256 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1259 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1262 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1264 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1266 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1269 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1271 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1273 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1275 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1278 if (src
->flavor
!= FL_UNKNOWN
1279 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1282 if (src
->intent
!= INTENT_UNKNOWN
1283 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1286 if (src
->access
!= ACCESS_UNKNOWN
1287 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1290 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1293 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1295 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1298 /* The subroutines that set these bits also cause flavors to be set,
1299 and that has already happened in the original, so don't let it
1304 dest
->intrinsic
= 1;
1313 /************** Component name management ************/
1315 /* Component names of a derived type form their own little namespaces
1316 that are separate from all other spaces. The space is composed of
1317 a singly linked list of gfc_component structures whose head is
1318 located in the parent symbol. */
1321 /* Add a component name to a symbol. The call fails if the name is
1322 already present. On success, the component pointer is modified to
1323 point to the additional component structure. */
1326 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1328 gfc_component
*p
, *tail
;
1332 for (p
= sym
->components
; p
; p
= p
->next
)
1334 if (strcmp (p
->name
, name
) == 0)
1336 gfc_error ("Component '%s' at %C already declared at %L",
1344 /* Allocate a new component. */
1345 p
= gfc_get_component ();
1348 sym
->components
= p
;
1352 p
->name
= gfc_get_string (name
);
1353 p
->loc
= gfc_current_locus
;
1360 /* Recursive function to switch derived types of all symbol in a
1364 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1372 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1373 sym
->ts
.derived
= to
;
1375 switch_types (st
->left
, from
, to
);
1376 switch_types (st
->right
, from
, to
);
1380 /* This subroutine is called when a derived type is used in order to
1381 make the final determination about which version to use. The
1382 standard requires that a type be defined before it is 'used', but
1383 such types can appear in IMPLICIT statements before the actual
1384 definition. 'Using' in this context means declaring a variable to
1385 be that type or using the type constructor.
1387 If a type is used and the components haven't been defined, then we
1388 have to have a derived type in a parent unit. We find the node in
1389 the other namespace and point the symtree node in this namespace to
1390 that node. Further reference to this name point to the correct
1391 node. If we can't find the node in a parent namespace, then we have
1394 This subroutine takes a pointer to a symbol node and returns a
1395 pointer to the translated node or NULL for an error. Usually there
1396 is no translation and we return the node we were passed. */
1399 gfc_use_derived (gfc_symbol
* sym
)
1406 if (sym
->components
!= NULL
)
1407 return sym
; /* Already defined. */
1409 if (sym
->ns
->parent
== NULL
)
1412 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1414 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1418 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1421 /* Get rid of symbol sym, translating all references to s. */
1422 for (i
= 0; i
< GFC_LETTERS
; i
++)
1424 t
= &sym
->ns
->default_type
[i
];
1425 if (t
->derived
== sym
)
1429 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1434 /* Unlink from list of modified symbols. */
1435 gfc_commit_symbol (sym
);
1437 switch_types (sym
->ns
->sym_root
, sym
, s
);
1439 /* TODO: Also have to replace sym -> s in other lists like
1440 namelists, common lists and interface lists. */
1441 gfc_free_symbol (sym
);
1446 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1452 /* Given a derived type node and a component name, try to locate the
1453 component structure. Returns the NULL pointer if the component is
1454 not found or the components are private. */
1457 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1464 sym
= gfc_use_derived (sym
);
1469 for (p
= sym
->components
; p
; p
= p
->next
)
1470 if (strcmp (p
->name
, name
) == 0)
1474 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1478 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1480 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1490 /* Given a symbol, free all of the component structures and everything
1494 free_components (gfc_component
* p
)
1502 gfc_free_array_spec (p
->as
);
1503 gfc_free_expr (p
->initializer
);
1510 /* Set component attributes from a standard symbol attribute
1514 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1517 c
->dimension
= attr
->dimension
;
1518 c
->pointer
= attr
->pointer
;
1522 /* Get a standard symbol attribute structure given the component
1526 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1529 gfc_clear_attr (attr
);
1530 attr
->dimension
= c
->dimension
;
1531 attr
->pointer
= c
->pointer
;
1535 /******************** Statement label management ********************/
1537 /* Comparison function for statement labels, used for managing the
1541 compare_st_labels (void * a1
, void * b1
)
1543 int a
= ((gfc_st_label
*)a1
)->value
;
1544 int b
= ((gfc_st_label
*)b1
)->value
;
1550 /* Free a single gfc_st_label structure, making sure the tree is not
1551 messed up. This function is called only when some parse error
1555 gfc_free_st_label (gfc_st_label
* label
)
1560 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1562 if (label
->format
!= NULL
)
1563 gfc_free_expr (label
->format
);
1568 /* Free a whole tree of gfc_st_label structures. */
1571 free_st_labels (gfc_st_label
* label
)
1576 free_st_labels (label
->left
);
1577 free_st_labels (label
->right
);
1579 if (label
->format
!= NULL
)
1580 gfc_free_expr (label
->format
);
1585 /* Given a label number, search for and return a pointer to the label
1586 structure, creating it if it does not exist. */
1589 gfc_get_st_label (int labelno
)
1593 /* First see if the label is already in this namespace. */
1594 lp
= gfc_current_ns
->st_labels
;
1597 if (lp
->value
== labelno
)
1600 if (lp
->value
< labelno
)
1606 lp
= gfc_getmem (sizeof (gfc_st_label
));
1608 lp
->value
= labelno
;
1609 lp
->defined
= ST_LABEL_UNKNOWN
;
1610 lp
->referenced
= ST_LABEL_UNKNOWN
;
1612 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1618 /* Called when a statement with a statement label is about to be
1619 accepted. We add the label to the list of the current namespace,
1620 making sure it hasn't been defined previously and referenced
1624 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1628 labelno
= lp
->value
;
1630 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1631 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1632 &lp
->where
, label_locus
);
1635 lp
->where
= *label_locus
;
1639 case ST_LABEL_FORMAT
:
1640 if (lp
->referenced
== ST_LABEL_TARGET
)
1641 gfc_error ("Label %d at %C already referenced as branch target",
1644 lp
->defined
= ST_LABEL_FORMAT
;
1648 case ST_LABEL_TARGET
:
1649 if (lp
->referenced
== ST_LABEL_FORMAT
)
1650 gfc_error ("Label %d at %C already referenced as a format label",
1653 lp
->defined
= ST_LABEL_TARGET
;
1658 lp
->defined
= ST_LABEL_BAD_TARGET
;
1659 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1665 /* Reference a label. Given a label and its type, see if that
1666 reference is consistent with what is known about that label,
1667 updating the unknown state. Returns FAILURE if something goes
1671 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1673 gfc_sl_type label_type
;
1680 labelno
= lp
->value
;
1682 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1683 label_type
= lp
->defined
;
1686 label_type
= lp
->referenced
;
1687 lp
->where
= gfc_current_locus
;
1690 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1692 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1697 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1698 && type
== ST_LABEL_FORMAT
)
1700 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1705 lp
->referenced
= type
;
1713 /************** Symbol table management subroutines ****************/
1715 /* Basic details: Fortran 95 requires a potentially unlimited number
1716 of distinct namespaces when compiling a program unit. This case
1717 occurs during a compilation of internal subprograms because all of
1718 the internal subprograms must be read before we can start
1719 generating code for the host.
1721 Given the tricky nature of the Fortran grammar, we must be able to
1722 undo changes made to a symbol table if the current interpretation
1723 of a statement is found to be incorrect. Whenever a symbol is
1724 looked up, we make a copy of it and link to it. All of these
1725 symbols are kept in a singly linked list so that we can commit or
1726 undo the changes at a later time.
1728 A symtree may point to a symbol node outside of its namespace. In
1729 this case, that symbol has been used as a host associated variable
1730 at some previous time. */
1732 /* Allocate a new namespace structure. Copies the implicit types from
1733 PARENT if PARENT_TYPES is set. */
1736 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1740 gfc_intrinsic_op in
;
1743 ns
= gfc_getmem (sizeof (gfc_namespace
));
1744 ns
->sym_root
= NULL
;
1745 ns
->uop_root
= NULL
;
1746 ns
->default_access
= ACCESS_UNKNOWN
;
1747 ns
->parent
= parent
;
1749 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1750 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1752 /* Initialize default implicit types. */
1753 for (i
= 'a'; i
<= 'z'; i
++)
1755 ns
->set_flag
[i
- 'a'] = 0;
1756 ts
= &ns
->default_type
[i
- 'a'];
1758 if (parent_types
&& ns
->parent
!= NULL
)
1760 /* Copy parent settings */
1761 *ts
= ns
->parent
->default_type
[i
- 'a'];
1765 if (gfc_option
.flag_implicit_none
!= 0)
1771 if ('i' <= i
&& i
<= 'n')
1773 ts
->type
= BT_INTEGER
;
1774 ts
->kind
= gfc_default_integer_kind
;
1779 ts
->kind
= gfc_default_real_kind
;
1789 /* Comparison function for symtree nodes. */
1792 compare_symtree (void * _st1
, void * _st2
)
1794 gfc_symtree
*st1
, *st2
;
1796 st1
= (gfc_symtree
*) _st1
;
1797 st2
= (gfc_symtree
*) _st2
;
1799 return strcmp (st1
->name
, st2
->name
);
1803 /* Allocate a new symtree node and associate it with the new symbol. */
1806 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1810 st
= gfc_getmem (sizeof (gfc_symtree
));
1811 st
->name
= gfc_get_string (name
);
1813 gfc_insert_bbt (root
, st
, compare_symtree
);
1818 /* Delete a symbol from the tree. Does not free the symbol itself! */
1821 delete_symtree (gfc_symtree
** root
, const char *name
)
1823 gfc_symtree st
, *st0
;
1825 st0
= gfc_find_symtree (*root
, name
);
1827 st
.name
= gfc_get_string (name
);
1828 gfc_delete_bbt (root
, &st
, compare_symtree
);
1834 /* Given a root symtree node and a name, try to find the symbol within
1835 the namespace. Returns NULL if the symbol is not found. */
1838 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1844 c
= strcmp (name
, st
->name
);
1848 st
= (c
< 0) ? st
->left
: st
->right
;
1855 /* Given a name find a user operator node, creating it if it doesn't
1856 exist. These are much simpler than symbols because they can't be
1857 ambiguous with one another. */
1860 gfc_get_uop (const char *name
)
1865 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1869 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1871 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1872 uop
->name
= gfc_get_string (name
);
1873 uop
->access
= ACCESS_UNKNOWN
;
1874 uop
->ns
= gfc_current_ns
;
1880 /* Given a name find the user operator node. Returns NULL if it does
1884 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1889 ns
= gfc_current_ns
;
1891 st
= gfc_find_symtree (ns
->uop_root
, name
);
1892 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1896 /* Remove a gfc_symbol structure and everything it points to. */
1899 gfc_free_symbol (gfc_symbol
* sym
)
1905 gfc_free_array_spec (sym
->as
);
1907 free_components (sym
->components
);
1909 gfc_free_expr (sym
->value
);
1911 gfc_free_namelist (sym
->namelist
);
1913 gfc_free_namespace (sym
->formal_ns
);
1915 gfc_free_interface (sym
->generic
);
1917 gfc_free_formal_arglist (sym
->formal
);
1923 /* Allocate and initialize a new symbol node. */
1926 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1930 p
= gfc_getmem (sizeof (gfc_symbol
));
1932 gfc_clear_ts (&p
->ts
);
1933 gfc_clear_attr (&p
->attr
);
1936 p
->declared_at
= gfc_current_locus
;
1938 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1939 gfc_internal_error ("new_symbol(): Symbol name too long");
1941 p
->name
= gfc_get_string (name
);
1946 /* Generate an error if a symbol is ambiguous. */
1949 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1952 if (st
->n
.sym
->module
)
1953 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1954 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1956 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1957 "from current program unit", name
, st
->n
.sym
->name
);
1961 /* Search for a symtree starting in the current namespace, resorting to
1962 any parent namespaces if requested by a nonzero parent_flag.
1963 Returns nonzero if the name is ambiguous. */
1966 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1967 gfc_symtree
** result
)
1972 ns
= gfc_current_ns
;
1976 st
= gfc_find_symtree (ns
->sym_root
, name
);
1982 ambiguous_symbol (name
, st
);
2001 /* Same, but returns the symbol instead. */
2004 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2005 gfc_symbol
** result
)
2010 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2015 *result
= st
->n
.sym
;
2021 /* Save symbol with the information necessary to back it out. */
2024 save_symbol_data (gfc_symbol
* sym
)
2027 if (sym
->new || sym
->old_symbol
!= NULL
)
2030 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2031 *(sym
->old_symbol
) = *sym
;
2033 sym
->tlink
= changed_syms
;
2038 /* Given a name, find a symbol, or create it if it does not exist yet
2039 in the current namespace. If the symbol is found we make sure that
2042 The integer return code indicates
2044 1 The symbol name was ambiguous
2045 2 The name meant to be established was already host associated.
2047 So if the return value is nonzero, then an error was issued. */
2050 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2055 /* This doesn't usually happen during resolution. */
2057 ns
= gfc_current_ns
;
2059 /* Try to find the symbol in ns. */
2060 st
= gfc_find_symtree (ns
->sym_root
, name
);
2064 /* If not there, create a new symbol. */
2065 p
= gfc_new_symbol (name
, ns
);
2067 /* Add to the list of tentative symbols. */
2068 p
->old_symbol
= NULL
;
2069 p
->tlink
= changed_syms
;
2074 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2081 /* Make sure the existing symbol is OK. */
2084 ambiguous_symbol (name
, st
);
2090 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2092 /* Symbol is from another namespace. */
2093 gfc_error ("Symbol '%s' at %C has already been host associated",
2100 /* Copy in case this symbol is changed. */
2101 save_symbol_data (p
);
2110 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2116 i
= gfc_get_sym_tree (name
, ns
, &st
);
2121 *result
= st
->n
.sym
;
2128 /* Subroutine that searches for a symbol, creating it if it doesn't
2129 exist, but tries to host-associate the symbol if possible. */
2132 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2137 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2140 save_symbol_data (st
->n
.sym
);
2146 if (gfc_current_ns
->parent
!= NULL
)
2148 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2159 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2164 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2169 i
= gfc_get_ha_sym_tree (name
, &st
);
2172 *result
= st
->n
.sym
;
2179 /* Return true if both symbols could refer to the same data object. Does
2180 not take account of aliasing due to equivalence statements. */
2183 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2185 /* Aliasing isn't possible if the symbols have different base types. */
2186 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2189 /* Pointers can point to other pointers, target objects and allocatable
2190 objects. Two allocatable objects cannot share the same storage. */
2191 if (lsym
->attr
.pointer
2192 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2194 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2196 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2203 /* Undoes all the changes made to symbols in the current statement.
2204 This subroutine is made simpler due to the fact that attributes are
2205 never removed once added. */
2208 gfc_undo_symbols (void)
2210 gfc_symbol
*p
, *q
, *old
;
2212 for (p
= changed_syms
; p
; p
= q
)
2218 /* Symbol was new. */
2219 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2223 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2225 gfc_free_symbol (p
);
2229 /* Restore previous state of symbol. Just copy simple stuff. */
2231 old
= p
->old_symbol
;
2233 p
->ts
.type
= old
->ts
.type
;
2234 p
->ts
.kind
= old
->ts
.kind
;
2236 p
->attr
= old
->attr
;
2238 if (p
->value
!= old
->value
)
2240 gfc_free_expr (old
->value
);
2244 if (p
->as
!= old
->as
)
2247 gfc_free_array_spec (p
->as
);
2251 p
->generic
= old
->generic
;
2252 p
->component_access
= old
->component_access
;
2254 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2256 gfc_free_namelist (p
->namelist
);
2262 if (p
->namelist_tail
!= old
->namelist_tail
)
2264 gfc_free_namelist (old
->namelist_tail
);
2265 old
->namelist_tail
->next
= NULL
;
2269 p
->namelist_tail
= old
->namelist_tail
;
2271 if (p
->formal
!= old
->formal
)
2273 gfc_free_formal_arglist (p
->formal
);
2274 p
->formal
= old
->formal
;
2277 gfc_free (p
->old_symbol
);
2278 p
->old_symbol
= NULL
;
2282 changed_syms
= NULL
;
2286 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2287 components of old_symbol that might need deallocation are the "allocatables"
2288 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2289 namelist_tail. In case these differ between old_symbol and sym, it's just
2290 because sym->namelist has gotten a few more items. */
2293 free_old_symbol (gfc_symbol
* sym
)
2295 if (sym
->old_symbol
== NULL
)
2298 if (sym
->old_symbol
->as
!= sym
->as
)
2299 gfc_free_array_spec (sym
->old_symbol
->as
);
2301 if (sym
->old_symbol
->value
!= sym
->value
)
2302 gfc_free_expr (sym
->old_symbol
->value
);
2304 if (sym
->old_symbol
->formal
!= sym
->formal
)
2305 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2307 gfc_free (sym
->old_symbol
);
2308 sym
->old_symbol
= NULL
;
2312 /* Makes the changes made in the current statement permanent-- gets
2313 rid of undo information. */
2316 gfc_commit_symbols (void)
2320 for (p
= changed_syms
; p
; p
= q
)
2327 free_old_symbol (p
);
2329 changed_syms
= NULL
;
2333 /* Makes the changes made in one symbol permanent -- gets rid of undo
2337 gfc_commit_symbol (gfc_symbol
* sym
)
2341 if (changed_syms
== sym
)
2342 changed_syms
= sym
->tlink
;
2345 for (p
= changed_syms
; p
; p
= p
->tlink
)
2346 if (p
->tlink
== sym
)
2348 p
->tlink
= sym
->tlink
;
2357 free_old_symbol (sym
);
2361 /* Recursive function that deletes an entire tree and all the common
2362 head structures it points to. */
2365 free_common_tree (gfc_symtree
* common_tree
)
2367 if (common_tree
== NULL
)
2370 free_common_tree (common_tree
->left
);
2371 free_common_tree (common_tree
->right
);
2373 gfc_free (common_tree
);
2377 /* Recursive function that deletes an entire tree and all the user
2378 operator nodes that it contains. */
2381 free_uop_tree (gfc_symtree
* uop_tree
)
2384 if (uop_tree
== NULL
)
2387 free_uop_tree (uop_tree
->left
);
2388 free_uop_tree (uop_tree
->right
);
2390 gfc_free_interface (uop_tree
->n
.uop
->operator);
2392 gfc_free (uop_tree
->n
.uop
);
2393 gfc_free (uop_tree
);
2397 /* Recursive function that deletes an entire tree and all the symbols
2398 that it contains. */
2401 free_sym_tree (gfc_symtree
* sym_tree
)
2406 if (sym_tree
== NULL
)
2409 free_sym_tree (sym_tree
->left
);
2410 free_sym_tree (sym_tree
->right
);
2412 sym
= sym_tree
->n
.sym
;
2416 gfc_internal_error ("free_sym_tree(): Negative refs");
2418 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2420 /* As formal_ns contains a reference to sym, delete formal_ns just
2421 before the deletion of sym. */
2422 ns
= sym
->formal_ns
;
2423 sym
->formal_ns
= NULL
;
2424 gfc_free_namespace (ns
);
2426 else if (sym
->refs
== 0)
2428 /* Go ahead and delete the symbol. */
2429 gfc_free_symbol (sym
);
2432 gfc_free (sym_tree
);
2436 /* Free a derived type list. */
2439 gfc_free_dt_list (gfc_dt_list
* dt
)
2451 /* Free the gfc_equiv_info's. */
2454 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2458 gfc_free_equiv_infos (s
->next
);
2463 /* Free the gfc_equiv_lists. */
2466 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2470 gfc_free_equiv_lists (l
->next
);
2471 gfc_free_equiv_infos (l
->equiv
);
2476 /* Free a namespace structure and everything below it. Interface
2477 lists associated with intrinsic operators are not freed. These are
2478 taken care of when a specific name is freed. */
2481 gfc_free_namespace (gfc_namespace
* ns
)
2483 gfc_charlen
*cl
, *cl2
;
2484 gfc_namespace
*p
, *q
;
2493 gcc_assert (ns
->refs
== 0);
2495 gfc_free_statements (ns
->code
);
2497 free_sym_tree (ns
->sym_root
);
2498 free_uop_tree (ns
->uop_root
);
2499 free_common_tree (ns
->common_root
);
2501 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2504 gfc_free_expr (cl
->length
);
2508 free_st_labels (ns
->st_labels
);
2510 gfc_free_equiv (ns
->equiv
);
2511 gfc_free_equiv_lists (ns
->equiv_lists
);
2513 gfc_free_dt_list (ns
->derived_types
);
2515 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2516 gfc_free_interface (ns
->operator[i
]);
2518 gfc_free_data (ns
->data
);
2522 /* Recursively free any contained namespaces. */
2528 gfc_free_namespace (q
);
2534 gfc_symbol_init_2 (void)
2537 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2542 gfc_symbol_done_2 (void)
2545 gfc_free_namespace (gfc_current_ns
);
2546 gfc_current_ns
= NULL
;
2550 /* Clear mark bits from symbol nodes associated with a symtree node. */
2553 clear_sym_mark (gfc_symtree
* st
)
2556 st
->n
.sym
->mark
= 0;
2560 /* Recursively traverse the symtree nodes. */
2563 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2569 gfc_traverse_symtree (st
->left
, func
);
2570 gfc_traverse_symtree (st
->right
, func
);
2575 /* Recursive namespace traversal function. */
2578 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2584 if (st
->n
.sym
->mark
== 0)
2585 (*func
) (st
->n
.sym
);
2586 st
->n
.sym
->mark
= 1;
2588 traverse_ns (st
->left
, func
);
2589 traverse_ns (st
->right
, func
);
2593 /* Call a given function for all symbols in the namespace. We take
2594 care that each gfc_symbol node is called exactly once. */
2597 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2600 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2602 traverse_ns (ns
->sym_root
, func
);
2606 /* Return TRUE if the symbol is an automatic variable. */
2608 gfc_is_var_automatic (gfc_symbol
* sym
)
2610 /* Pointer and allocatable variables are never automatic. */
2611 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2613 /* Check for arrays with non-constant size. */
2614 if (sym
->attr
.dimension
&& sym
->as
2615 && !gfc_is_compile_time_shape (sym
->as
))
2617 /* Check for non-constant length character variables. */
2618 if (sym
->ts
.type
== BT_CHARACTER
2620 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2625 /* Given a symbol, mark it as SAVEd if it is allowed. */
2628 save_symbol (gfc_symbol
* sym
)
2631 if (sym
->attr
.use_assoc
)
2634 if (sym
->attr
.in_common
2636 || sym
->attr
.flavor
!= FL_VARIABLE
)
2638 /* Automatic objects are not saved. */
2639 if (gfc_is_var_automatic (sym
))
2641 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2645 /* Mark those symbols which can be SAVEd as such. */
2648 gfc_save_all (gfc_namespace
* ns
)
2651 gfc_traverse_ns (ns
, save_symbol
);
2656 /* Make sure that no changes to symbols are pending. */
2659 gfc_symbol_state(void) {
2661 if (changed_syms
!= NULL
)
2662 gfc_internal_error("Symbol changes still pending!");
2667 /************** Global symbol handling ************/
2670 /* Search a tree for the global symbol. */
2673 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2679 if (strcmp (symbol
->name
, name
) == 0)
2682 s
= gfc_find_gsymbol (symbol
->left
, name
);
2686 s
= gfc_find_gsymbol (symbol
->right
, name
);
2694 /* Compare two global symbols. Used for managing the BB tree. */
2697 gsym_compare (void * _s1
, void * _s2
)
2699 gfc_gsymbol
*s1
, *s2
;
2701 s1
= (gfc_gsymbol
*)_s1
;
2702 s2
= (gfc_gsymbol
*)_s2
;
2703 return strcmp(s1
->name
, s2
->name
);
2707 /* Get a global symbol, creating it if it doesn't exist. */
2710 gfc_get_gsymbol (const char *name
)
2714 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2718 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2719 s
->type
= GSYM_UNKNOWN
;
2720 s
->name
= gfc_get_string (name
);
2722 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);