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 /* Used to prevent changing the attributes of a symbol after it has been
605 used. This check is only done for dummy variables as only these can be
606 used in specification expressions. Applying this to all symbols causes
607 an error when we reach the body of a contained function. */
610 check_done (symbol_attribute
* attr
, locus
* where
)
613 if (!(attr
->dummy
&& attr
->referenced
))
617 where
= &gfc_current_locus
;
619 gfc_error ("Cannot change attributes of symbol at %L"
620 " after it has been used", where
);
626 /* Generate an error because of a duplicate attribute. */
629 duplicate_attr (const char *attr
, locus
* where
)
633 where
= &gfc_current_locus
;
635 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
638 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
641 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
,
642 unsigned int attr_intent
)
645 if (check_used (attr
, NULL
, where
)
646 || (attr_intent
== 0 && check_done (attr
, where
)))
649 return check_conflict (attr
, NULL
, where
);
653 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
656 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
659 if (attr
->allocatable
)
661 duplicate_attr ("ALLOCATABLE", where
);
665 attr
->allocatable
= 1;
666 return check_conflict (attr
, NULL
, where
);
671 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
674 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
679 duplicate_attr ("DIMENSION", where
);
684 return check_conflict (attr
, name
, where
);
689 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
692 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
697 duplicate_attr ("EXTERNAL", where
);
703 return check_conflict (attr
, NULL
, where
);
708 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
711 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
716 duplicate_attr ("INTRINSIC", where
);
722 return check_conflict (attr
, NULL
, where
);
727 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
730 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
735 duplicate_attr ("OPTIONAL", where
);
740 return check_conflict (attr
, NULL
, where
);
745 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
748 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
752 return check_conflict (attr
, NULL
, where
);
757 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
760 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
763 attr
->cray_pointer
= 1;
764 return check_conflict (attr
, NULL
, where
);
769 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
772 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
775 if (attr
->cray_pointee
)
777 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
778 " statements.", where
);
782 attr
->cray_pointee
= 1;
783 return check_conflict (attr
, NULL
, where
);
788 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
791 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
795 return check_conflict (attr
, name
, where
);
800 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
803 if (check_used (attr
, name
, where
))
809 ("SAVE attribute at %L cannot be specified in a PURE procedure",
816 if (gfc_notify_std (GFC_STD_LEGACY
,
817 "Duplicate SAVE attribute specified at %L",
824 return check_conflict (attr
, name
, where
);
828 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
831 if (check_used (attr
, name
, where
))
836 if (gfc_notify_std (GFC_STD_LEGACY
,
837 "Duplicate VOLATILE attribute specified at %L",
844 return check_conflict (attr
, name
, where
);
849 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
851 if (check_used (attr
, name
, where
))
854 if (attr
->threadprivate
)
856 duplicate_attr ("THREADPRIVATE", where
);
860 attr
->threadprivate
= 1;
861 return check_conflict (attr
, name
, where
);
866 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
869 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
874 duplicate_attr ("TARGET", where
);
879 return check_conflict (attr
, NULL
, where
);
884 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
887 if (check_used (attr
, name
, where
))
890 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
892 return check_conflict (attr
, name
, where
);
897 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
900 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
903 /* Duplicate attribute already checked for. */
905 if (check_conflict (attr
, name
, where
) == FAILURE
)
908 if (attr
->flavor
== FL_VARIABLE
)
911 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
915 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
918 /* Duplicate attribute already checked for. */
919 attr
->in_equivalence
= 1;
920 if (check_conflict (attr
, name
, where
) == FAILURE
)
923 if (attr
->flavor
== FL_VARIABLE
)
926 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
931 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
934 if (check_used (attr
, name
, where
))
938 return check_conflict (attr
, name
, where
);
943 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
947 attr
->in_namelist
= 1;
948 return check_conflict (attr
, name
, where
);
953 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
956 if (check_used (attr
, name
, where
))
960 return check_conflict (attr
, name
, where
);
965 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
968 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
972 return check_conflict (attr
, NULL
, where
);
977 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
980 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
984 return check_conflict (attr
, NULL
, where
);
989 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
992 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
996 return check_conflict (attr
, NULL
, where
);
1001 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1004 if (check_used (attr
, name
, where
))
1009 duplicate_attr ("ENTRY", where
);
1014 return check_conflict (attr
, name
, where
);
1019 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1022 if (attr
->flavor
!= FL_PROCEDURE
1023 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1027 return check_conflict (attr
, name
, where
);
1032 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1035 if (attr
->flavor
!= FL_PROCEDURE
1036 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1039 attr
->subroutine
= 1;
1040 return check_conflict (attr
, name
, where
);
1045 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1048 if (attr
->flavor
!= FL_PROCEDURE
1049 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1053 return check_conflict (attr
, name
, where
);
1057 /* Flavors are special because some flavors are not what Fortran
1058 considers attributes and can be reaffirmed multiple times. */
1061 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1065 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1066 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1067 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1070 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1073 if (attr
->flavor
!= FL_UNKNOWN
)
1076 where
= &gfc_current_locus
;
1078 gfc_error ("%s attribute conflicts with %s attribute at %L",
1079 gfc_code2string (flavors
, attr
->flavor
),
1080 gfc_code2string (flavors
, f
), where
);
1087 return check_conflict (attr
, name
, where
);
1092 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1093 const char *name
, locus
* where
)
1096 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1099 if (attr
->flavor
!= FL_PROCEDURE
1100 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1104 where
= &gfc_current_locus
;
1106 if (attr
->proc
!= PROC_UNKNOWN
)
1108 gfc_error ("%s procedure at %L is already declared as %s procedure",
1109 gfc_code2string (procedures
, t
), where
,
1110 gfc_code2string (procedures
, attr
->proc
));
1117 /* Statement functions are always scalar and functions. */
1118 if (t
== PROC_ST_FUNCTION
1119 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1120 || attr
->dimension
))
1123 return check_conflict (attr
, name
, where
);
1128 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1131 if (check_used (attr
, NULL
, where
))
1134 if (attr
->intent
== INTENT_UNKNOWN
)
1136 attr
->intent
= intent
;
1137 return check_conflict (attr
, NULL
, where
);
1141 where
= &gfc_current_locus
;
1143 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1144 gfc_intent_string (attr
->intent
),
1145 gfc_intent_string (intent
), where
);
1151 /* No checks for use-association in public and private statements. */
1154 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1155 const char *name
, locus
* where
)
1158 if (attr
->access
== ACCESS_UNKNOWN
)
1160 attr
->access
= access
;
1161 return check_conflict (attr
, name
, where
);
1165 where
= &gfc_current_locus
;
1166 gfc_error ("ACCESS specification at %L was already specified", where
);
1173 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1174 gfc_formal_arglist
* formal
, locus
* where
)
1177 if (check_used (&sym
->attr
, sym
->name
, where
))
1181 where
= &gfc_current_locus
;
1183 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1184 && sym
->attr
.if_source
!= IFSRC_DECL
)
1186 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1191 sym
->formal
= formal
;
1192 sym
->attr
.if_source
= source
;
1198 /* Add a type to a symbol. */
1201 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1205 /* TODO: This is legal if it is reaffirming an implicit type.
1206 if (check_done (&sym->attr, where))
1210 where
= &gfc_current_locus
;
1212 if (sym
->ts
.type
!= BT_UNKNOWN
)
1214 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1215 if (!(sym
->ts
.type
== ts
->type
1216 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1217 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1220 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1223 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1224 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1228 flavor
= sym
->attr
.flavor
;
1230 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1231 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1232 && sym
->attr
.subroutine
)
1233 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1235 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1244 /* Clears all attributes. */
1247 gfc_clear_attr (symbol_attribute
* attr
)
1249 memset (attr
, 0, sizeof(symbol_attribute
));
1253 /* Check for missing attributes in the new symbol. Currently does
1254 nothing, but it's not clear that it is unnecessary yet. */
1257 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1258 locus
* where ATTRIBUTE_UNUSED
)
1265 /* Copy an attribute to a symbol attribute, bit by bit. Some
1266 attributes have a lot of side-effects but cannot be present given
1267 where we are called from, so we ignore some bits. */
1270 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1273 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1276 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1278 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1280 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1282 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1284 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1286 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1288 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1290 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1292 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1297 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1300 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1303 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1305 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1307 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1310 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1312 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1314 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1316 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1319 if (src
->flavor
!= FL_UNKNOWN
1320 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1323 if (src
->intent
!= INTENT_UNKNOWN
1324 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1327 if (src
->access
!= ACCESS_UNKNOWN
1328 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1331 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1334 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1336 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1339 /* The subroutines that set these bits also cause flavors to be set,
1340 and that has already happened in the original, so don't let it
1345 dest
->intrinsic
= 1;
1354 /************** Component name management ************/
1356 /* Component names of a derived type form their own little namespaces
1357 that are separate from all other spaces. The space is composed of
1358 a singly linked list of gfc_component structures whose head is
1359 located in the parent symbol. */
1362 /* Add a component name to a symbol. The call fails if the name is
1363 already present. On success, the component pointer is modified to
1364 point to the additional component structure. */
1367 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1369 gfc_component
*p
, *tail
;
1373 for (p
= sym
->components
; p
; p
= p
->next
)
1375 if (strcmp (p
->name
, name
) == 0)
1377 gfc_error ("Component '%s' at %C already declared at %L",
1385 /* Allocate a new component. */
1386 p
= gfc_get_component ();
1389 sym
->components
= p
;
1393 p
->name
= gfc_get_string (name
);
1394 p
->loc
= gfc_current_locus
;
1401 /* Recursive function to switch derived types of all symbol in a
1405 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1413 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1414 sym
->ts
.derived
= to
;
1416 switch_types (st
->left
, from
, to
);
1417 switch_types (st
->right
, from
, to
);
1421 /* This subroutine is called when a derived type is used in order to
1422 make the final determination about which version to use. The
1423 standard requires that a type be defined before it is 'used', but
1424 such types can appear in IMPLICIT statements before the actual
1425 definition. 'Using' in this context means declaring a variable to
1426 be that type or using the type constructor.
1428 If a type is used and the components haven't been defined, then we
1429 have to have a derived type in a parent unit. We find the node in
1430 the other namespace and point the symtree node in this namespace to
1431 that node. Further reference to this name point to the correct
1432 node. If we can't find the node in a parent namespace, then we have
1435 This subroutine takes a pointer to a symbol node and returns a
1436 pointer to the translated node or NULL for an error. Usually there
1437 is no translation and we return the node we were passed. */
1440 gfc_use_derived (gfc_symbol
* sym
)
1447 if (sym
->components
!= NULL
)
1448 return sym
; /* Already defined. */
1450 if (sym
->ns
->parent
== NULL
)
1453 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1455 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1459 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1462 /* Get rid of symbol sym, translating all references to s. */
1463 for (i
= 0; i
< GFC_LETTERS
; i
++)
1465 t
= &sym
->ns
->default_type
[i
];
1466 if (t
->derived
== sym
)
1470 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1475 /* Unlink from list of modified symbols. */
1476 gfc_commit_symbol (sym
);
1478 switch_types (sym
->ns
->sym_root
, sym
, s
);
1480 /* TODO: Also have to replace sym -> s in other lists like
1481 namelists, common lists and interface lists. */
1482 gfc_free_symbol (sym
);
1487 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1493 /* Given a derived type node and a component name, try to locate the
1494 component structure. Returns the NULL pointer if the component is
1495 not found or the components are private. */
1498 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1505 sym
= gfc_use_derived (sym
);
1510 for (p
= sym
->components
; p
; p
= p
->next
)
1511 if (strcmp (p
->name
, name
) == 0)
1515 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1519 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1521 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1531 /* Given a symbol, free all of the component structures and everything
1535 free_components (gfc_component
* p
)
1543 gfc_free_array_spec (p
->as
);
1544 gfc_free_expr (p
->initializer
);
1551 /* Set component attributes from a standard symbol attribute
1555 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1558 c
->dimension
= attr
->dimension
;
1559 c
->pointer
= attr
->pointer
;
1560 c
->allocatable
= attr
->allocatable
;
1564 /* Get a standard symbol attribute structure given the component
1568 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1571 gfc_clear_attr (attr
);
1572 attr
->dimension
= c
->dimension
;
1573 attr
->pointer
= c
->pointer
;
1574 attr
->allocatable
= c
->allocatable
;
1578 /******************** Statement label management ********************/
1580 /* Comparison function for statement labels, used for managing the
1584 compare_st_labels (void * a1
, void * b1
)
1586 int a
= ((gfc_st_label
*)a1
)->value
;
1587 int b
= ((gfc_st_label
*)b1
)->value
;
1593 /* Free a single gfc_st_label structure, making sure the tree is not
1594 messed up. This function is called only when some parse error
1598 gfc_free_st_label (gfc_st_label
* label
)
1603 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1605 if (label
->format
!= NULL
)
1606 gfc_free_expr (label
->format
);
1611 /* Free a whole tree of gfc_st_label structures. */
1614 free_st_labels (gfc_st_label
* label
)
1619 free_st_labels (label
->left
);
1620 free_st_labels (label
->right
);
1622 if (label
->format
!= NULL
)
1623 gfc_free_expr (label
->format
);
1628 /* Given a label number, search for and return a pointer to the label
1629 structure, creating it if it does not exist. */
1632 gfc_get_st_label (int labelno
)
1636 /* First see if the label is already in this namespace. */
1637 lp
= gfc_current_ns
->st_labels
;
1640 if (lp
->value
== labelno
)
1643 if (lp
->value
< labelno
)
1649 lp
= gfc_getmem (sizeof (gfc_st_label
));
1651 lp
->value
= labelno
;
1652 lp
->defined
= ST_LABEL_UNKNOWN
;
1653 lp
->referenced
= ST_LABEL_UNKNOWN
;
1655 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1661 /* Called when a statement with a statement label is about to be
1662 accepted. We add the label to the list of the current namespace,
1663 making sure it hasn't been defined previously and referenced
1667 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1671 labelno
= lp
->value
;
1673 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1674 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1675 &lp
->where
, label_locus
);
1678 lp
->where
= *label_locus
;
1682 case ST_LABEL_FORMAT
:
1683 if (lp
->referenced
== ST_LABEL_TARGET
)
1684 gfc_error ("Label %d at %C already referenced as branch target",
1687 lp
->defined
= ST_LABEL_FORMAT
;
1691 case ST_LABEL_TARGET
:
1692 if (lp
->referenced
== ST_LABEL_FORMAT
)
1693 gfc_error ("Label %d at %C already referenced as a format label",
1696 lp
->defined
= ST_LABEL_TARGET
;
1701 lp
->defined
= ST_LABEL_BAD_TARGET
;
1702 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1708 /* Reference a label. Given a label and its type, see if that
1709 reference is consistent with what is known about that label,
1710 updating the unknown state. Returns FAILURE if something goes
1714 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1716 gfc_sl_type label_type
;
1723 labelno
= lp
->value
;
1725 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1726 label_type
= lp
->defined
;
1729 label_type
= lp
->referenced
;
1730 lp
->where
= gfc_current_locus
;
1733 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1735 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1740 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1741 && type
== ST_LABEL_FORMAT
)
1743 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1748 lp
->referenced
= type
;
1756 /************** Symbol table management subroutines ****************/
1758 /* Basic details: Fortran 95 requires a potentially unlimited number
1759 of distinct namespaces when compiling a program unit. This case
1760 occurs during a compilation of internal subprograms because all of
1761 the internal subprograms must be read before we can start
1762 generating code for the host.
1764 Given the tricky nature of the Fortran grammar, we must be able to
1765 undo changes made to a symbol table if the current interpretation
1766 of a statement is found to be incorrect. Whenever a symbol is
1767 looked up, we make a copy of it and link to it. All of these
1768 symbols are kept in a singly linked list so that we can commit or
1769 undo the changes at a later time.
1771 A symtree may point to a symbol node outside of its namespace. In
1772 this case, that symbol has been used as a host associated variable
1773 at some previous time. */
1775 /* Allocate a new namespace structure. Copies the implicit types from
1776 PARENT if PARENT_TYPES is set. */
1779 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1783 gfc_intrinsic_op in
;
1786 ns
= gfc_getmem (sizeof (gfc_namespace
));
1787 ns
->sym_root
= NULL
;
1788 ns
->uop_root
= NULL
;
1789 ns
->default_access
= ACCESS_UNKNOWN
;
1790 ns
->parent
= parent
;
1792 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1793 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1795 /* Initialize default implicit types. */
1796 for (i
= 'a'; i
<= 'z'; i
++)
1798 ns
->set_flag
[i
- 'a'] = 0;
1799 ts
= &ns
->default_type
[i
- 'a'];
1801 if (parent_types
&& ns
->parent
!= NULL
)
1803 /* Copy parent settings */
1804 *ts
= ns
->parent
->default_type
[i
- 'a'];
1808 if (gfc_option
.flag_implicit_none
!= 0)
1814 if ('i' <= i
&& i
<= 'n')
1816 ts
->type
= BT_INTEGER
;
1817 ts
->kind
= gfc_default_integer_kind
;
1822 ts
->kind
= gfc_default_real_kind
;
1832 /* Comparison function for symtree nodes. */
1835 compare_symtree (void * _st1
, void * _st2
)
1837 gfc_symtree
*st1
, *st2
;
1839 st1
= (gfc_symtree
*) _st1
;
1840 st2
= (gfc_symtree
*) _st2
;
1842 return strcmp (st1
->name
, st2
->name
);
1846 /* Allocate a new symtree node and associate it with the new symbol. */
1849 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1853 st
= gfc_getmem (sizeof (gfc_symtree
));
1854 st
->name
= gfc_get_string (name
);
1856 gfc_insert_bbt (root
, st
, compare_symtree
);
1861 /* Delete a symbol from the tree. Does not free the symbol itself! */
1864 delete_symtree (gfc_symtree
** root
, const char *name
)
1866 gfc_symtree st
, *st0
;
1868 st0
= gfc_find_symtree (*root
, name
);
1870 st
.name
= gfc_get_string (name
);
1871 gfc_delete_bbt (root
, &st
, compare_symtree
);
1877 /* Given a root symtree node and a name, try to find the symbol within
1878 the namespace. Returns NULL if the symbol is not found. */
1881 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1887 c
= strcmp (name
, st
->name
);
1891 st
= (c
< 0) ? st
->left
: st
->right
;
1898 /* Given a name find a user operator node, creating it if it doesn't
1899 exist. These are much simpler than symbols because they can't be
1900 ambiguous with one another. */
1903 gfc_get_uop (const char *name
)
1908 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1912 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1914 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1915 uop
->name
= gfc_get_string (name
);
1916 uop
->access
= ACCESS_UNKNOWN
;
1917 uop
->ns
= gfc_current_ns
;
1923 /* Given a name find the user operator node. Returns NULL if it does
1927 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1932 ns
= gfc_current_ns
;
1934 st
= gfc_find_symtree (ns
->uop_root
, name
);
1935 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1939 /* Remove a gfc_symbol structure and everything it points to. */
1942 gfc_free_symbol (gfc_symbol
* sym
)
1948 gfc_free_array_spec (sym
->as
);
1950 free_components (sym
->components
);
1952 gfc_free_expr (sym
->value
);
1954 gfc_free_namelist (sym
->namelist
);
1956 gfc_free_namespace (sym
->formal_ns
);
1958 gfc_free_interface (sym
->generic
);
1960 gfc_free_formal_arglist (sym
->formal
);
1966 /* Allocate and initialize a new symbol node. */
1969 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1973 p
= gfc_getmem (sizeof (gfc_symbol
));
1975 gfc_clear_ts (&p
->ts
);
1976 gfc_clear_attr (&p
->attr
);
1979 p
->declared_at
= gfc_current_locus
;
1981 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1982 gfc_internal_error ("new_symbol(): Symbol name too long");
1984 p
->name
= gfc_get_string (name
);
1989 /* Generate an error if a symbol is ambiguous. */
1992 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1995 if (st
->n
.sym
->module
)
1996 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1997 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1999 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2000 "from current program unit", name
, st
->n
.sym
->name
);
2004 /* Search for a symtree starting in the current namespace, resorting to
2005 any parent namespaces if requested by a nonzero parent_flag.
2006 Returns nonzero if the name is ambiguous. */
2009 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2010 gfc_symtree
** result
)
2015 ns
= gfc_current_ns
;
2019 st
= gfc_find_symtree (ns
->sym_root
, name
);
2025 ambiguous_symbol (name
, st
);
2044 /* Same, but returns the symbol instead. */
2047 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2048 gfc_symbol
** result
)
2053 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2058 *result
= st
->n
.sym
;
2064 /* Save symbol with the information necessary to back it out. */
2067 save_symbol_data (gfc_symbol
* sym
)
2070 if (sym
->new || sym
->old_symbol
!= NULL
)
2073 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2074 *(sym
->old_symbol
) = *sym
;
2076 sym
->tlink
= changed_syms
;
2081 /* Given a name, find a symbol, or create it if it does not exist yet
2082 in the current namespace. If the symbol is found we make sure that
2085 The integer return code indicates
2087 1 The symbol name was ambiguous
2088 2 The name meant to be established was already host associated.
2090 So if the return value is nonzero, then an error was issued. */
2093 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2098 /* This doesn't usually happen during resolution. */
2100 ns
= gfc_current_ns
;
2102 /* Try to find the symbol in ns. */
2103 st
= gfc_find_symtree (ns
->sym_root
, name
);
2107 /* If not there, create a new symbol. */
2108 p
= gfc_new_symbol (name
, ns
);
2110 /* Add to the list of tentative symbols. */
2111 p
->old_symbol
= NULL
;
2112 p
->tlink
= changed_syms
;
2117 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2124 /* Make sure the existing symbol is OK. */
2127 ambiguous_symbol (name
, st
);
2133 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2135 /* Symbol is from another namespace. */
2136 gfc_error ("Symbol '%s' at %C has already been host associated",
2143 /* Copy in case this symbol is changed. */
2144 save_symbol_data (p
);
2153 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2159 i
= gfc_get_sym_tree (name
, ns
, &st
);
2164 *result
= st
->n
.sym
;
2171 /* Subroutine that searches for a symbol, creating it if it doesn't
2172 exist, but tries to host-associate the symbol if possible. */
2175 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2180 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2183 save_symbol_data (st
->n
.sym
);
2189 if (gfc_current_ns
->parent
!= NULL
)
2191 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2202 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2207 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2212 i
= gfc_get_ha_sym_tree (name
, &st
);
2215 *result
= st
->n
.sym
;
2222 /* Return true if both symbols could refer to the same data object. Does
2223 not take account of aliasing due to equivalence statements. */
2226 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2228 /* Aliasing isn't possible if the symbols have different base types. */
2229 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2232 /* Pointers can point to other pointers, target objects and allocatable
2233 objects. Two allocatable objects cannot share the same storage. */
2234 if (lsym
->attr
.pointer
2235 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2237 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2239 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2246 /* Undoes all the changes made to symbols in the current statement.
2247 This subroutine is made simpler due to the fact that attributes are
2248 never removed once added. */
2251 gfc_undo_symbols (void)
2253 gfc_symbol
*p
, *q
, *old
;
2255 for (p
= changed_syms
; p
; p
= q
)
2261 /* Symbol was new. */
2262 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2266 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2268 gfc_free_symbol (p
);
2272 /* Restore previous state of symbol. Just copy simple stuff. */
2274 old
= p
->old_symbol
;
2276 p
->ts
.type
= old
->ts
.type
;
2277 p
->ts
.kind
= old
->ts
.kind
;
2279 p
->attr
= old
->attr
;
2281 if (p
->value
!= old
->value
)
2283 gfc_free_expr (old
->value
);
2287 if (p
->as
!= old
->as
)
2290 gfc_free_array_spec (p
->as
);
2294 p
->generic
= old
->generic
;
2295 p
->component_access
= old
->component_access
;
2297 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2299 gfc_free_namelist (p
->namelist
);
2305 if (p
->namelist_tail
!= old
->namelist_tail
)
2307 gfc_free_namelist (old
->namelist_tail
);
2308 old
->namelist_tail
->next
= NULL
;
2312 p
->namelist_tail
= old
->namelist_tail
;
2314 if (p
->formal
!= old
->formal
)
2316 gfc_free_formal_arglist (p
->formal
);
2317 p
->formal
= old
->formal
;
2320 gfc_free (p
->old_symbol
);
2321 p
->old_symbol
= NULL
;
2325 changed_syms
= NULL
;
2329 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2330 components of old_symbol that might need deallocation are the "allocatables"
2331 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2332 namelist_tail. In case these differ between old_symbol and sym, it's just
2333 because sym->namelist has gotten a few more items. */
2336 free_old_symbol (gfc_symbol
* sym
)
2338 if (sym
->old_symbol
== NULL
)
2341 if (sym
->old_symbol
->as
!= sym
->as
)
2342 gfc_free_array_spec (sym
->old_symbol
->as
);
2344 if (sym
->old_symbol
->value
!= sym
->value
)
2345 gfc_free_expr (sym
->old_symbol
->value
);
2347 if (sym
->old_symbol
->formal
!= sym
->formal
)
2348 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2350 gfc_free (sym
->old_symbol
);
2351 sym
->old_symbol
= NULL
;
2355 /* Makes the changes made in the current statement permanent-- gets
2356 rid of undo information. */
2359 gfc_commit_symbols (void)
2363 for (p
= changed_syms
; p
; p
= q
)
2370 free_old_symbol (p
);
2372 changed_syms
= NULL
;
2376 /* Makes the changes made in one symbol permanent -- gets rid of undo
2380 gfc_commit_symbol (gfc_symbol
* sym
)
2384 if (changed_syms
== sym
)
2385 changed_syms
= sym
->tlink
;
2388 for (p
= changed_syms
; p
; p
= p
->tlink
)
2389 if (p
->tlink
== sym
)
2391 p
->tlink
= sym
->tlink
;
2400 free_old_symbol (sym
);
2404 /* Recursive function that deletes an entire tree and all the common
2405 head structures it points to. */
2408 free_common_tree (gfc_symtree
* common_tree
)
2410 if (common_tree
== NULL
)
2413 free_common_tree (common_tree
->left
);
2414 free_common_tree (common_tree
->right
);
2416 gfc_free (common_tree
);
2420 /* Recursive function that deletes an entire tree and all the user
2421 operator nodes that it contains. */
2424 free_uop_tree (gfc_symtree
* uop_tree
)
2427 if (uop_tree
== NULL
)
2430 free_uop_tree (uop_tree
->left
);
2431 free_uop_tree (uop_tree
->right
);
2433 gfc_free_interface (uop_tree
->n
.uop
->operator);
2435 gfc_free (uop_tree
->n
.uop
);
2436 gfc_free (uop_tree
);
2440 /* Recursive function that deletes an entire tree and all the symbols
2441 that it contains. */
2444 free_sym_tree (gfc_symtree
* sym_tree
)
2449 if (sym_tree
== NULL
)
2452 free_sym_tree (sym_tree
->left
);
2453 free_sym_tree (sym_tree
->right
);
2455 sym
= sym_tree
->n
.sym
;
2459 gfc_internal_error ("free_sym_tree(): Negative refs");
2461 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2463 /* As formal_ns contains a reference to sym, delete formal_ns just
2464 before the deletion of sym. */
2465 ns
= sym
->formal_ns
;
2466 sym
->formal_ns
= NULL
;
2467 gfc_free_namespace (ns
);
2469 else if (sym
->refs
== 0)
2471 /* Go ahead and delete the symbol. */
2472 gfc_free_symbol (sym
);
2475 gfc_free (sym_tree
);
2479 /* Free a derived type list. */
2482 gfc_free_dt_list (gfc_dt_list
* dt
)
2494 /* Free the gfc_equiv_info's. */
2497 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2501 gfc_free_equiv_infos (s
->next
);
2506 /* Free the gfc_equiv_lists. */
2509 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2513 gfc_free_equiv_lists (l
->next
);
2514 gfc_free_equiv_infos (l
->equiv
);
2519 /* Free a namespace structure and everything below it. Interface
2520 lists associated with intrinsic operators are not freed. These are
2521 taken care of when a specific name is freed. */
2524 gfc_free_namespace (gfc_namespace
* ns
)
2526 gfc_charlen
*cl
, *cl2
;
2527 gfc_namespace
*p
, *q
;
2536 gcc_assert (ns
->refs
== 0);
2538 gfc_free_statements (ns
->code
);
2540 free_sym_tree (ns
->sym_root
);
2541 free_uop_tree (ns
->uop_root
);
2542 free_common_tree (ns
->common_root
);
2544 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2547 gfc_free_expr (cl
->length
);
2551 free_st_labels (ns
->st_labels
);
2553 gfc_free_equiv (ns
->equiv
);
2554 gfc_free_equiv_lists (ns
->equiv_lists
);
2556 gfc_free_dt_list (ns
->derived_types
);
2558 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2559 gfc_free_interface (ns
->operator[i
]);
2561 gfc_free_data (ns
->data
);
2565 /* Recursively free any contained namespaces. */
2571 gfc_free_namespace (q
);
2577 gfc_symbol_init_2 (void)
2580 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2585 gfc_symbol_done_2 (void)
2588 gfc_free_namespace (gfc_current_ns
);
2589 gfc_current_ns
= NULL
;
2593 /* Clear mark bits from symbol nodes associated with a symtree node. */
2596 clear_sym_mark (gfc_symtree
* st
)
2599 st
->n
.sym
->mark
= 0;
2603 /* Recursively traverse the symtree nodes. */
2606 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2612 gfc_traverse_symtree (st
->left
, func
);
2613 gfc_traverse_symtree (st
->right
, func
);
2618 /* Recursive namespace traversal function. */
2621 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2627 if (st
->n
.sym
->mark
== 0)
2628 (*func
) (st
->n
.sym
);
2629 st
->n
.sym
->mark
= 1;
2631 traverse_ns (st
->left
, func
);
2632 traverse_ns (st
->right
, func
);
2636 /* Call a given function for all symbols in the namespace. We take
2637 care that each gfc_symbol node is called exactly once. */
2640 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2643 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2645 traverse_ns (ns
->sym_root
, func
);
2649 /* Return TRUE if the symbol is an automatic variable. */
2651 gfc_is_var_automatic (gfc_symbol
* sym
)
2653 /* Pointer and allocatable variables are never automatic. */
2654 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2656 /* Check for arrays with non-constant size. */
2657 if (sym
->attr
.dimension
&& sym
->as
2658 && !gfc_is_compile_time_shape (sym
->as
))
2660 /* Check for non-constant length character variables. */
2661 if (sym
->ts
.type
== BT_CHARACTER
2663 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2668 /* Given a symbol, mark it as SAVEd if it is allowed. */
2671 save_symbol (gfc_symbol
* sym
)
2674 if (sym
->attr
.use_assoc
)
2677 if (sym
->attr
.in_common
2679 || sym
->attr
.flavor
!= FL_VARIABLE
)
2681 /* Automatic objects are not saved. */
2682 if (gfc_is_var_automatic (sym
))
2684 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2688 /* Mark those symbols which can be SAVEd as such. */
2691 gfc_save_all (gfc_namespace
* ns
)
2694 gfc_traverse_ns (ns
, save_symbol
);
2699 /* Make sure that no changes to symbols are pending. */
2702 gfc_symbol_state(void) {
2704 if (changed_syms
!= NULL
)
2705 gfc_internal_error("Symbol changes still pending!");
2710 /************** Global symbol handling ************/
2713 /* Search a tree for the global symbol. */
2716 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2722 if (strcmp (symbol
->name
, name
) == 0)
2725 s
= gfc_find_gsymbol (symbol
->left
, name
);
2729 s
= gfc_find_gsymbol (symbol
->right
, name
);
2737 /* Compare two global symbols. Used for managing the BB tree. */
2740 gsym_compare (void * _s1
, void * _s2
)
2742 gfc_gsymbol
*s1
, *s2
;
2744 s1
= (gfc_gsymbol
*)_s1
;
2745 s2
= (gfc_gsymbol
*)_s2
;
2746 return strcmp(s1
->name
, s2
->name
);
2750 /* Get a global symbol, creating it if it doesn't exist. */
2753 gfc_get_gsymbol (const char *name
)
2757 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2761 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2762 s
->type
= GSYM_UNKNOWN
;
2763 s
->name
= gfc_get_string (name
);
2765 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);