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];
206 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
207 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
208 "gfortran developers, and should not be used for "
209 "implicitly typed variables");
211 if (letter
< 'a' || letter
> 'z')
212 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
217 return &ns
->default_type
[letter
- 'a'];
221 /* Given a pointer to a symbol, set its type according to the first
222 letter of its name. Fails if the letter in question has no default
226 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
230 if (sym
->ts
.type
!= BT_UNKNOWN
)
231 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
233 ts
= gfc_get_default_type (sym
, ns
);
235 if (ts
->type
== BT_UNKNOWN
)
237 if (error_flag
&& !sym
->attr
.untyped
)
239 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
240 sym
->name
, &sym
->declared_at
);
241 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
248 sym
->attr
.implicit_type
= 1;
254 /******************** Symbol attribute stuff *********************/
256 /* This is a generic conflict-checker. We do this to avoid having a
257 single conflict in two places. */
259 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
260 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
261 #define conf_std(a, b, std) if (attr->a && attr->b)\
270 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
272 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
273 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
274 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
275 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
276 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
277 *private = "PRIVATE", *recursive
= "RECURSIVE",
278 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
279 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
280 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
281 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
282 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
283 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
284 *volatile_
= "VOLATILE", *protected = "PROTECTED";
285 static const char *threadprivate
= "THREADPRIVATE";
291 where
= &gfc_current_locus
;
293 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
297 standard
= GFC_STD_F2003
;
301 /* Check for attributes not allowed in a BLOCK DATA. */
302 if (gfc_current_state () == COMP_BLOCK_DATA
)
306 if (attr
->in_namelist
)
308 if (attr
->allocatable
)
314 if (attr
->access
== ACCESS_PRIVATE
)
316 if (attr
->access
== ACCESS_PUBLIC
)
318 if (attr
->intent
!= INTENT_UNKNOWN
)
324 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
331 conf (dummy
, intrinsic
);
333 conf (dummy
, threadprivate
);
334 conf (pointer
, target
);
335 conf (pointer
, external
);
336 conf (pointer
, intrinsic
);
337 conf (pointer
, elemental
);
338 conf (allocatable
, elemental
);
340 conf (target
, external
);
341 conf (target
, intrinsic
);
342 conf (external
, dimension
); /* See Fortran 95's R504. */
344 conf (external
, intrinsic
);
346 if (attr
->if_source
|| attr
->contained
)
348 conf (external
, subroutine
);
349 conf (external
, function
);
352 conf (allocatable
, pointer
);
353 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
354 conf_std (allocatable
, function
, GFC_STD_F2003
);
355 conf_std (allocatable
, result
, GFC_STD_F2003
);
356 conf (elemental
, recursive
);
358 conf (in_common
, dummy
);
359 conf (in_common
, allocatable
);
360 conf (in_common
, result
);
361 conf (in_common
, save
);
364 conf (dummy
, result
);
366 conf (in_equivalence
, use_assoc
);
367 conf (in_equivalence
, dummy
);
368 conf (in_equivalence
, target
);
369 conf (in_equivalence
, pointer
);
370 conf (in_equivalence
, function
);
371 conf (in_equivalence
, result
);
372 conf (in_equivalence
, entry
);
373 conf (in_equivalence
, allocatable
);
374 conf (in_equivalence
, threadprivate
);
376 conf (in_namelist
, pointer
);
377 conf (in_namelist
, allocatable
);
379 conf (entry
, result
);
381 conf (function
, subroutine
);
383 /* Cray pointer/pointee conflicts. */
384 conf (cray_pointer
, cray_pointee
);
385 conf (cray_pointer
, dimension
);
386 conf (cray_pointer
, pointer
);
387 conf (cray_pointer
, target
);
388 conf (cray_pointer
, allocatable
);
389 conf (cray_pointer
, external
);
390 conf (cray_pointer
, intrinsic
);
391 conf (cray_pointer
, in_namelist
);
392 conf (cray_pointer
, function
);
393 conf (cray_pointer
, subroutine
);
394 conf (cray_pointer
, entry
);
396 conf (cray_pointee
, allocatable
);
397 conf (cray_pointee
, intent
);
398 conf (cray_pointee
, optional
);
399 conf (cray_pointee
, dummy
);
400 conf (cray_pointee
, target
);
401 conf (cray_pointee
, intrinsic
);
402 conf (cray_pointee
, pointer
);
403 conf (cray_pointee
, entry
);
404 conf (cray_pointee
, in_common
);
405 conf (cray_pointee
, in_equivalence
);
406 conf (cray_pointee
, threadprivate
);
409 conf (data
, function
);
411 conf (data
, allocatable
);
412 conf (data
, use_assoc
);
414 conf (protected, intrinsic
)
415 conf (protected, external
)
416 conf (protected, in_common
)
418 conf (value
, pointer
)
419 conf (value
, allocatable
)
420 conf (value
, subroutine
)
421 conf (value
, function
)
422 conf (value
, volatile_
)
423 conf (value
, dimension
)
424 conf (value
, external
)
426 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
429 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
433 conf (volatile_
, intrinsic
)
434 conf (volatile_
, external
)
436 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
443 a1
= gfc_code2string (flavors
, attr
->flavor
);
445 if (attr
->in_namelist
446 && attr
->flavor
!= FL_VARIABLE
447 && attr
->flavor
!= FL_UNKNOWN
)
454 switch (attr
->flavor
)
475 conf2 (threadprivate
);
486 if (attr
->subroutine
)
495 conf2(threadprivate
);
500 case PROC_ST_FUNCTION
:
513 conf2 (threadprivate
);
534 conf2 (threadprivate
);
536 if (attr
->intent
!= INTENT_UNKNOWN
)
559 conf2 (threadprivate
);
570 gfc_error ("%s attribute conflicts with %s attribute at %L",
573 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
574 a1
, a2
, name
, where
);
581 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
582 "with %s attribute at %L", a1
, a2
,
587 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
588 "with %s attribute in '%s' at %L",
589 a1
, a2
, name
, where
);
598 /* Mark a symbol as referenced. */
601 gfc_set_sym_referenced (gfc_symbol
* sym
)
603 if (sym
->attr
.referenced
)
606 sym
->attr
.referenced
= 1;
608 /* Remember which order dummy variables are accessed in. */
610 sym
->dummy_order
= next_dummy_order
++;
614 /* Common subroutine called by attribute changing subroutines in order
615 to prevent them from changing a symbol that has been
616 use-associated. Returns zero if it is OK to change the symbol,
620 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
623 if (attr
->use_assoc
== 0)
627 where
= &gfc_current_locus
;
630 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
633 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
640 /* Generate an error because of a duplicate attribute. */
643 duplicate_attr (const char *attr
, locus
* where
)
647 where
= &gfc_current_locus
;
649 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
652 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
655 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
657 if (check_used (attr
, NULL
, where
))
660 return check_conflict (attr
, NULL
, where
);
664 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
667 if (check_used (attr
, NULL
, where
))
670 if (attr
->allocatable
)
672 duplicate_attr ("ALLOCATABLE", where
);
676 attr
->allocatable
= 1;
677 return check_conflict (attr
, NULL
, where
);
682 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
685 if (check_used (attr
, name
, where
))
690 duplicate_attr ("DIMENSION", where
);
695 return check_conflict (attr
, name
, where
);
700 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
703 if (check_used (attr
, NULL
, where
))
708 duplicate_attr ("EXTERNAL", where
);
714 return check_conflict (attr
, NULL
, where
);
719 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
722 if (check_used (attr
, NULL
, where
))
727 duplicate_attr ("INTRINSIC", where
);
733 return check_conflict (attr
, NULL
, where
);
738 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
741 if (check_used (attr
, NULL
, where
))
746 duplicate_attr ("OPTIONAL", where
);
751 return check_conflict (attr
, NULL
, where
);
756 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
759 if (check_used (attr
, NULL
, where
))
763 return check_conflict (attr
, NULL
, where
);
768 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
771 if (check_used (attr
, NULL
, where
))
774 attr
->cray_pointer
= 1;
775 return check_conflict (attr
, NULL
, where
);
780 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
783 if (check_used (attr
, NULL
, where
))
786 if (attr
->cray_pointee
)
788 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
789 " statements", where
);
793 attr
->cray_pointee
= 1;
794 return check_conflict (attr
, NULL
, where
);
798 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
800 if (check_used (attr
, name
, where
))
805 if (gfc_notify_std (GFC_STD_LEGACY
,
806 "Duplicate PROTECTED attribute specified at %L",
813 return check_conflict (attr
, name
, where
);
817 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
820 if (check_used (attr
, name
, where
))
824 return check_conflict (attr
, name
, where
);
829 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
832 if (check_used (attr
, name
, where
))
838 ("SAVE attribute at %L cannot be specified in a PURE procedure",
845 if (gfc_notify_std (GFC_STD_LEGACY
,
846 "Duplicate SAVE attribute specified at %L",
853 return check_conflict (attr
, name
, where
);
857 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
860 if (check_used (attr
, name
, where
))
865 if (gfc_notify_std (GFC_STD_LEGACY
,
866 "Duplicate VALUE attribute specified at %L",
873 return check_conflict (attr
, name
, where
);
877 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
880 if (check_used (attr
, name
, where
))
885 if (gfc_notify_std (GFC_STD_LEGACY
,
886 "Duplicate VOLATILE attribute specified at %L",
893 return check_conflict (attr
, name
, where
);
898 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
900 if (check_used (attr
, name
, where
))
903 if (attr
->threadprivate
)
905 duplicate_attr ("THREADPRIVATE", where
);
909 attr
->threadprivate
= 1;
910 return check_conflict (attr
, name
, where
);
915 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
918 if (check_used (attr
, NULL
, where
))
923 duplicate_attr ("TARGET", where
);
928 return check_conflict (attr
, NULL
, where
);
933 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
936 if (check_used (attr
, name
, where
))
939 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
941 return check_conflict (attr
, name
, where
);
946 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
949 if (check_used (attr
, name
, where
))
952 /* Duplicate attribute already checked for. */
954 if (check_conflict (attr
, name
, where
) == FAILURE
)
957 if (attr
->flavor
== FL_VARIABLE
)
960 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
964 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
967 /* Duplicate attribute already checked for. */
968 attr
->in_equivalence
= 1;
969 if (check_conflict (attr
, name
, where
) == FAILURE
)
972 if (attr
->flavor
== FL_VARIABLE
)
975 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
980 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
983 if (check_used (attr
, name
, where
))
987 return check_conflict (attr
, name
, where
);
992 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
996 attr
->in_namelist
= 1;
997 return check_conflict (attr
, name
, where
);
1002 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
1005 if (check_used (attr
, name
, where
))
1009 return check_conflict (attr
, name
, where
);
1014 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1017 if (check_used (attr
, NULL
, where
))
1020 attr
->elemental
= 1;
1021 return check_conflict (attr
, NULL
, where
);
1026 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1029 if (check_used (attr
, NULL
, where
))
1033 return check_conflict (attr
, NULL
, where
);
1038 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1041 if (check_used (attr
, NULL
, where
))
1044 attr
->recursive
= 1;
1045 return check_conflict (attr
, NULL
, where
);
1050 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1053 if (check_used (attr
, name
, where
))
1058 duplicate_attr ("ENTRY", where
);
1063 return check_conflict (attr
, name
, where
);
1068 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1071 if (attr
->flavor
!= FL_PROCEDURE
1072 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1076 return check_conflict (attr
, name
, where
);
1081 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1084 if (attr
->flavor
!= FL_PROCEDURE
1085 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1088 attr
->subroutine
= 1;
1089 return check_conflict (attr
, name
, where
);
1094 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1097 if (attr
->flavor
!= FL_PROCEDURE
1098 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1102 return check_conflict (attr
, name
, where
);
1106 /* Flavors are special because some flavors are not what Fortran
1107 considers attributes and can be reaffirmed multiple times. */
1110 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1114 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1115 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1116 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1119 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1122 if (attr
->flavor
!= FL_UNKNOWN
)
1125 where
= &gfc_current_locus
;
1127 gfc_error ("%s attribute conflicts with %s attribute at %L",
1128 gfc_code2string (flavors
, attr
->flavor
),
1129 gfc_code2string (flavors
, f
), where
);
1136 return check_conflict (attr
, name
, where
);
1141 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1142 const char *name
, locus
* where
)
1145 if (check_used (attr
, name
, where
))
1148 if (attr
->flavor
!= FL_PROCEDURE
1149 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1153 where
= &gfc_current_locus
;
1155 if (attr
->proc
!= PROC_UNKNOWN
)
1157 gfc_error ("%s procedure at %L is already declared as %s procedure",
1158 gfc_code2string (procedures
, t
), where
,
1159 gfc_code2string (procedures
, attr
->proc
));
1166 /* Statement functions are always scalar and functions. */
1167 if (t
== PROC_ST_FUNCTION
1168 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1169 || attr
->dimension
))
1172 return check_conflict (attr
, name
, where
);
1177 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1180 if (check_used (attr
, NULL
, where
))
1183 if (attr
->intent
== INTENT_UNKNOWN
)
1185 attr
->intent
= intent
;
1186 return check_conflict (attr
, NULL
, where
);
1190 where
= &gfc_current_locus
;
1192 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1193 gfc_intent_string (attr
->intent
),
1194 gfc_intent_string (intent
), where
);
1200 /* No checks for use-association in public and private statements. */
1203 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1204 const char *name
, locus
* where
)
1207 if (attr
->access
== ACCESS_UNKNOWN
)
1209 attr
->access
= access
;
1210 return check_conflict (attr
, name
, where
);
1214 where
= &gfc_current_locus
;
1215 gfc_error ("ACCESS specification at %L was already specified", where
);
1222 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1223 gfc_formal_arglist
* formal
, locus
* where
)
1226 if (check_used (&sym
->attr
, sym
->name
, where
))
1230 where
= &gfc_current_locus
;
1232 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1233 && sym
->attr
.if_source
!= IFSRC_DECL
)
1235 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1240 sym
->formal
= formal
;
1241 sym
->attr
.if_source
= source
;
1247 /* Add a type to a symbol. */
1250 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1255 where
= &gfc_current_locus
;
1257 if (sym
->ts
.type
!= BT_UNKNOWN
)
1259 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1260 if (!(sym
->ts
.type
== ts
->type
1261 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1262 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1265 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1268 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1269 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1273 flavor
= sym
->attr
.flavor
;
1275 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1276 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1277 && sym
->attr
.subroutine
)
1278 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1280 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1289 /* Clears all attributes. */
1292 gfc_clear_attr (symbol_attribute
* attr
)
1294 memset (attr
, 0, sizeof(symbol_attribute
));
1298 /* Check for missing attributes in the new symbol. Currently does
1299 nothing, but it's not clear that it is unnecessary yet. */
1302 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1303 locus
* where ATTRIBUTE_UNUSED
)
1310 /* Copy an attribute to a symbol attribute, bit by bit. Some
1311 attributes have a lot of side-effects but cannot be present given
1312 where we are called from, so we ignore some bits. */
1315 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1318 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1321 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1323 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1325 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1327 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1329 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1331 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1333 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1335 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1337 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1339 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1341 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1346 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1349 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1352 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1354 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1356 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1359 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1361 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1363 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1365 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1368 if (src
->flavor
!= FL_UNKNOWN
1369 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1372 if (src
->intent
!= INTENT_UNKNOWN
1373 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1376 if (src
->access
!= ACCESS_UNKNOWN
1377 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1380 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1383 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1385 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1388 /* The subroutines that set these bits also cause flavors to be set,
1389 and that has already happened in the original, so don't let it
1394 dest
->intrinsic
= 1;
1403 /************** Component name management ************/
1405 /* Component names of a derived type form their own little namespaces
1406 that are separate from all other spaces. The space is composed of
1407 a singly linked list of gfc_component structures whose head is
1408 located in the parent symbol. */
1411 /* Add a component name to a symbol. The call fails if the name is
1412 already present. On success, the component pointer is modified to
1413 point to the additional component structure. */
1416 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1418 gfc_component
*p
, *tail
;
1422 for (p
= sym
->components
; p
; p
= p
->next
)
1424 if (strcmp (p
->name
, name
) == 0)
1426 gfc_error ("Component '%s' at %C already declared at %L",
1434 /* Allocate a new component. */
1435 p
= gfc_get_component ();
1438 sym
->components
= p
;
1442 p
->name
= gfc_get_string (name
);
1443 p
->loc
= gfc_current_locus
;
1450 /* Recursive function to switch derived types of all symbol in a
1454 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1462 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1463 sym
->ts
.derived
= to
;
1465 switch_types (st
->left
, from
, to
);
1466 switch_types (st
->right
, from
, to
);
1470 /* This subroutine is called when a derived type is used in order to
1471 make the final determination about which version to use. The
1472 standard requires that a type be defined before it is 'used', but
1473 such types can appear in IMPLICIT statements before the actual
1474 definition. 'Using' in this context means declaring a variable to
1475 be that type or using the type constructor.
1477 If a type is used and the components haven't been defined, then we
1478 have to have a derived type in a parent unit. We find the node in
1479 the other namespace and point the symtree node in this namespace to
1480 that node. Further reference to this name point to the correct
1481 node. If we can't find the node in a parent namespace, then we have
1484 This subroutine takes a pointer to a symbol node and returns a
1485 pointer to the translated node or NULL for an error. Usually there
1486 is no translation and we return the node we were passed. */
1489 gfc_use_derived (gfc_symbol
* sym
)
1496 if (sym
->components
!= NULL
)
1497 return sym
; /* Already defined. */
1499 if (sym
->ns
->parent
== NULL
)
1502 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1504 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1508 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1511 /* Get rid of symbol sym, translating all references to s. */
1512 for (i
= 0; i
< GFC_LETTERS
; i
++)
1514 t
= &sym
->ns
->default_type
[i
];
1515 if (t
->derived
== sym
)
1519 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1524 /* Unlink from list of modified symbols. */
1525 gfc_commit_symbol (sym
);
1527 switch_types (sym
->ns
->sym_root
, sym
, s
);
1529 /* TODO: Also have to replace sym -> s in other lists like
1530 namelists, common lists and interface lists. */
1531 gfc_free_symbol (sym
);
1536 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1542 /* Given a derived type node and a component name, try to locate the
1543 component structure. Returns the NULL pointer if the component is
1544 not found or the components are private. */
1547 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1554 sym
= gfc_use_derived (sym
);
1559 for (p
= sym
->components
; p
; p
= p
->next
)
1560 if (strcmp (p
->name
, name
) == 0)
1564 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1568 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1570 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1580 /* Given a symbol, free all of the component structures and everything
1584 free_components (gfc_component
* p
)
1592 gfc_free_array_spec (p
->as
);
1593 gfc_free_expr (p
->initializer
);
1600 /* Set component attributes from a standard symbol attribute
1604 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1607 c
->dimension
= attr
->dimension
;
1608 c
->pointer
= attr
->pointer
;
1609 c
->allocatable
= attr
->allocatable
;
1613 /* Get a standard symbol attribute structure given the component
1617 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1620 gfc_clear_attr (attr
);
1621 attr
->dimension
= c
->dimension
;
1622 attr
->pointer
= c
->pointer
;
1623 attr
->allocatable
= c
->allocatable
;
1627 /******************** Statement label management ********************/
1629 /* Comparison function for statement labels, used for managing the
1633 compare_st_labels (void * a1
, void * b1
)
1635 int a
= ((gfc_st_label
*)a1
)->value
;
1636 int b
= ((gfc_st_label
*)b1
)->value
;
1642 /* Free a single gfc_st_label structure, making sure the tree is not
1643 messed up. This function is called only when some parse error
1647 gfc_free_st_label (gfc_st_label
* label
)
1652 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1654 if (label
->format
!= NULL
)
1655 gfc_free_expr (label
->format
);
1660 /* Free a whole tree of gfc_st_label structures. */
1663 free_st_labels (gfc_st_label
* label
)
1668 free_st_labels (label
->left
);
1669 free_st_labels (label
->right
);
1671 if (label
->format
!= NULL
)
1672 gfc_free_expr (label
->format
);
1677 /* Given a label number, search for and return a pointer to the label
1678 structure, creating it if it does not exist. */
1681 gfc_get_st_label (int labelno
)
1685 /* First see if the label is already in this namespace. */
1686 lp
= gfc_current_ns
->st_labels
;
1689 if (lp
->value
== labelno
)
1692 if (lp
->value
< labelno
)
1698 lp
= gfc_getmem (sizeof (gfc_st_label
));
1700 lp
->value
= labelno
;
1701 lp
->defined
= ST_LABEL_UNKNOWN
;
1702 lp
->referenced
= ST_LABEL_UNKNOWN
;
1704 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1710 /* Called when a statement with a statement label is about to be
1711 accepted. We add the label to the list of the current namespace,
1712 making sure it hasn't been defined previously and referenced
1716 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1720 labelno
= lp
->value
;
1722 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1723 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1724 &lp
->where
, label_locus
);
1727 lp
->where
= *label_locus
;
1731 case ST_LABEL_FORMAT
:
1732 if (lp
->referenced
== ST_LABEL_TARGET
)
1733 gfc_error ("Label %d at %C already referenced as branch target",
1736 lp
->defined
= ST_LABEL_FORMAT
;
1740 case ST_LABEL_TARGET
:
1741 if (lp
->referenced
== ST_LABEL_FORMAT
)
1742 gfc_error ("Label %d at %C already referenced as a format label",
1745 lp
->defined
= ST_LABEL_TARGET
;
1750 lp
->defined
= ST_LABEL_BAD_TARGET
;
1751 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1757 /* Reference a label. Given a label and its type, see if that
1758 reference is consistent with what is known about that label,
1759 updating the unknown state. Returns FAILURE if something goes
1763 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1765 gfc_sl_type label_type
;
1772 labelno
= lp
->value
;
1774 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1775 label_type
= lp
->defined
;
1778 label_type
= lp
->referenced
;
1779 lp
->where
= gfc_current_locus
;
1782 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1784 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1789 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1790 && type
== ST_LABEL_FORMAT
)
1792 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1797 lp
->referenced
= type
;
1805 /************** Symbol table management subroutines ****************/
1807 /* Basic details: Fortran 95 requires a potentially unlimited number
1808 of distinct namespaces when compiling a program unit. This case
1809 occurs during a compilation of internal subprograms because all of
1810 the internal subprograms must be read before we can start
1811 generating code for the host.
1813 Given the tricky nature of the Fortran grammar, we must be able to
1814 undo changes made to a symbol table if the current interpretation
1815 of a statement is found to be incorrect. Whenever a symbol is
1816 looked up, we make a copy of it and link to it. All of these
1817 symbols are kept in a singly linked list so that we can commit or
1818 undo the changes at a later time.
1820 A symtree may point to a symbol node outside of its namespace. In
1821 this case, that symbol has been used as a host associated variable
1822 at some previous time. */
1824 /* Allocate a new namespace structure. Copies the implicit types from
1825 PARENT if PARENT_TYPES is set. */
1828 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1832 gfc_intrinsic_op in
;
1835 ns
= gfc_getmem (sizeof (gfc_namespace
));
1836 ns
->sym_root
= NULL
;
1837 ns
->uop_root
= NULL
;
1838 ns
->default_access
= ACCESS_UNKNOWN
;
1839 ns
->parent
= parent
;
1841 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1842 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1844 /* Initialize default implicit types. */
1845 for (i
= 'a'; i
<= 'z'; i
++)
1847 ns
->set_flag
[i
- 'a'] = 0;
1848 ts
= &ns
->default_type
[i
- 'a'];
1850 if (parent_types
&& ns
->parent
!= NULL
)
1852 /* Copy parent settings */
1853 *ts
= ns
->parent
->default_type
[i
- 'a'];
1857 if (gfc_option
.flag_implicit_none
!= 0)
1863 if ('i' <= i
&& i
<= 'n')
1865 ts
->type
= BT_INTEGER
;
1866 ts
->kind
= gfc_default_integer_kind
;
1871 ts
->kind
= gfc_default_real_kind
;
1881 /* Comparison function for symtree nodes. */
1884 compare_symtree (void * _st1
, void * _st2
)
1886 gfc_symtree
*st1
, *st2
;
1888 st1
= (gfc_symtree
*) _st1
;
1889 st2
= (gfc_symtree
*) _st2
;
1891 return strcmp (st1
->name
, st2
->name
);
1895 /* Allocate a new symtree node and associate it with the new symbol. */
1898 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1902 st
= gfc_getmem (sizeof (gfc_symtree
));
1903 st
->name
= gfc_get_string (name
);
1905 gfc_insert_bbt (root
, st
, compare_symtree
);
1910 /* Delete a symbol from the tree. Does not free the symbol itself! */
1913 delete_symtree (gfc_symtree
** root
, const char *name
)
1915 gfc_symtree st
, *st0
;
1917 st0
= gfc_find_symtree (*root
, name
);
1919 st
.name
= gfc_get_string (name
);
1920 gfc_delete_bbt (root
, &st
, compare_symtree
);
1926 /* Given a root symtree node and a name, try to find the symbol within
1927 the namespace. Returns NULL if the symbol is not found. */
1930 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1936 c
= strcmp (name
, st
->name
);
1940 st
= (c
< 0) ? st
->left
: st
->right
;
1947 /* Given a name find a user operator node, creating it if it doesn't
1948 exist. These are much simpler than symbols because they can't be
1949 ambiguous with one another. */
1952 gfc_get_uop (const char *name
)
1957 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1961 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1963 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1964 uop
->name
= gfc_get_string (name
);
1965 uop
->access
= ACCESS_UNKNOWN
;
1966 uop
->ns
= gfc_current_ns
;
1972 /* Given a name find the user operator node. Returns NULL if it does
1976 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1981 ns
= gfc_current_ns
;
1983 st
= gfc_find_symtree (ns
->uop_root
, name
);
1984 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1988 /* Remove a gfc_symbol structure and everything it points to. */
1991 gfc_free_symbol (gfc_symbol
* sym
)
1997 gfc_free_array_spec (sym
->as
);
1999 free_components (sym
->components
);
2001 gfc_free_expr (sym
->value
);
2003 gfc_free_namelist (sym
->namelist
);
2005 gfc_free_namespace (sym
->formal_ns
);
2007 if (!sym
->attr
.generic_copy
)
2008 gfc_free_interface (sym
->generic
);
2010 gfc_free_formal_arglist (sym
->formal
);
2016 /* Allocate and initialize a new symbol node. */
2019 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2023 p
= gfc_getmem (sizeof (gfc_symbol
));
2025 gfc_clear_ts (&p
->ts
);
2026 gfc_clear_attr (&p
->attr
);
2029 p
->declared_at
= gfc_current_locus
;
2031 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2032 gfc_internal_error ("new_symbol(): Symbol name too long");
2034 p
->name
= gfc_get_string (name
);
2039 /* Generate an error if a symbol is ambiguous. */
2042 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2045 if (st
->n
.sym
->module
)
2046 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2047 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2049 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2050 "from current program unit", name
, st
->n
.sym
->name
);
2054 /* Search for a symtree starting in the current namespace, resorting to
2055 any parent namespaces if requested by a nonzero parent_flag.
2056 Returns nonzero if the name is ambiguous. */
2059 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2060 gfc_symtree
** result
)
2065 ns
= gfc_current_ns
;
2069 st
= gfc_find_symtree (ns
->sym_root
, name
);
2073 /* Ambiguous generic interfaces are permitted, as long
2074 as the specific interfaces are different. */
2075 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2077 ambiguous_symbol (name
, st
);
2096 /* Same, but returns the symbol instead. */
2099 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2100 gfc_symbol
** result
)
2105 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2110 *result
= st
->n
.sym
;
2116 /* Save symbol with the information necessary to back it out. */
2119 save_symbol_data (gfc_symbol
* sym
)
2122 if (sym
->new || sym
->old_symbol
!= NULL
)
2125 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2126 *(sym
->old_symbol
) = *sym
;
2128 sym
->tlink
= changed_syms
;
2133 /* Given a name, find a symbol, or create it if it does not exist yet
2134 in the current namespace. If the symbol is found we make sure that
2137 The integer return code indicates
2139 1 The symbol name was ambiguous
2140 2 The name meant to be established was already host associated.
2142 So if the return value is nonzero, then an error was issued. */
2145 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2150 /* This doesn't usually happen during resolution. */
2152 ns
= gfc_current_ns
;
2154 /* Try to find the symbol in ns. */
2155 st
= gfc_find_symtree (ns
->sym_root
, name
);
2159 /* If not there, create a new symbol. */
2160 p
= gfc_new_symbol (name
, ns
);
2162 /* Add to the list of tentative symbols. */
2163 p
->old_symbol
= NULL
;
2164 p
->tlink
= changed_syms
;
2169 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2176 /* Make sure the existing symbol is OK. Ambiguous
2177 generic interfaces are permitted, as long as the
2178 specific interfaces are different. */
2179 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2181 ambiguous_symbol (name
, st
);
2187 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2189 /* Symbol is from another namespace. */
2190 gfc_error ("Symbol '%s' at %C has already been host associated",
2197 /* Copy in case this symbol is changed. */
2198 save_symbol_data (p
);
2207 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2213 i
= gfc_get_sym_tree (name
, ns
, &st
);
2218 *result
= st
->n
.sym
;
2225 /* Subroutine that searches for a symbol, creating it if it doesn't
2226 exist, but tries to host-associate the symbol if possible. */
2229 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2234 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2237 save_symbol_data (st
->n
.sym
);
2243 if (gfc_current_ns
->parent
!= NULL
)
2245 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2256 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2261 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2266 i
= gfc_get_ha_sym_tree (name
, &st
);
2269 *result
= st
->n
.sym
;
2276 /* Return true if both symbols could refer to the same data object. Does
2277 not take account of aliasing due to equivalence statements. */
2280 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2282 /* Aliasing isn't possible if the symbols have different base types. */
2283 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2286 /* Pointers can point to other pointers, target objects and allocatable
2287 objects. Two allocatable objects cannot share the same storage. */
2288 if (lsym
->attr
.pointer
2289 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2291 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2293 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2300 /* Undoes all the changes made to symbols in the current statement.
2301 This subroutine is made simpler due to the fact that attributes are
2302 never removed once added. */
2305 gfc_undo_symbols (void)
2307 gfc_symbol
*p
, *q
, *old
;
2309 for (p
= changed_syms
; p
; p
= q
)
2315 /* Symbol was new. */
2316 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2320 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2322 gfc_free_symbol (p
);
2326 /* Restore previous state of symbol. Just copy simple stuff. */
2328 old
= p
->old_symbol
;
2330 p
->ts
.type
= old
->ts
.type
;
2331 p
->ts
.kind
= old
->ts
.kind
;
2333 p
->attr
= old
->attr
;
2335 if (p
->value
!= old
->value
)
2337 gfc_free_expr (old
->value
);
2341 if (p
->as
!= old
->as
)
2344 gfc_free_array_spec (p
->as
);
2348 p
->generic
= old
->generic
;
2349 p
->component_access
= old
->component_access
;
2351 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2353 gfc_free_namelist (p
->namelist
);
2359 if (p
->namelist_tail
!= old
->namelist_tail
)
2361 gfc_free_namelist (old
->namelist_tail
);
2362 old
->namelist_tail
->next
= NULL
;
2366 p
->namelist_tail
= old
->namelist_tail
;
2368 if (p
->formal
!= old
->formal
)
2370 gfc_free_formal_arglist (p
->formal
);
2371 p
->formal
= old
->formal
;
2374 gfc_free (p
->old_symbol
);
2375 p
->old_symbol
= NULL
;
2379 changed_syms
= NULL
;
2383 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2384 components of old_symbol that might need deallocation are the "allocatables"
2385 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2386 namelist_tail. In case these differ between old_symbol and sym, it's just
2387 because sym->namelist has gotten a few more items. */
2390 free_old_symbol (gfc_symbol
* sym
)
2392 if (sym
->old_symbol
== NULL
)
2395 if (sym
->old_symbol
->as
!= sym
->as
)
2396 gfc_free_array_spec (sym
->old_symbol
->as
);
2398 if (sym
->old_symbol
->value
!= sym
->value
)
2399 gfc_free_expr (sym
->old_symbol
->value
);
2401 if (sym
->old_symbol
->formal
!= sym
->formal
)
2402 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2404 gfc_free (sym
->old_symbol
);
2405 sym
->old_symbol
= NULL
;
2409 /* Makes the changes made in the current statement permanent-- gets
2410 rid of undo information. */
2413 gfc_commit_symbols (void)
2417 for (p
= changed_syms
; p
; p
= q
)
2424 free_old_symbol (p
);
2426 changed_syms
= NULL
;
2430 /* Makes the changes made in one symbol permanent -- gets rid of undo
2434 gfc_commit_symbol (gfc_symbol
* sym
)
2438 if (changed_syms
== sym
)
2439 changed_syms
= sym
->tlink
;
2442 for (p
= changed_syms
; p
; p
= p
->tlink
)
2443 if (p
->tlink
== sym
)
2445 p
->tlink
= sym
->tlink
;
2454 free_old_symbol (sym
);
2458 /* Recursive function that deletes an entire tree and all the common
2459 head structures it points to. */
2462 free_common_tree (gfc_symtree
* common_tree
)
2464 if (common_tree
== NULL
)
2467 free_common_tree (common_tree
->left
);
2468 free_common_tree (common_tree
->right
);
2470 gfc_free (common_tree
);
2474 /* Recursive function that deletes an entire tree and all the user
2475 operator nodes that it contains. */
2478 free_uop_tree (gfc_symtree
* uop_tree
)
2481 if (uop_tree
== NULL
)
2484 free_uop_tree (uop_tree
->left
);
2485 free_uop_tree (uop_tree
->right
);
2487 gfc_free_interface (uop_tree
->n
.uop
->operator);
2489 gfc_free (uop_tree
->n
.uop
);
2490 gfc_free (uop_tree
);
2494 /* Recursive function that deletes an entire tree and all the symbols
2495 that it contains. */
2498 free_sym_tree (gfc_symtree
* sym_tree
)
2503 if (sym_tree
== NULL
)
2506 free_sym_tree (sym_tree
->left
);
2507 free_sym_tree (sym_tree
->right
);
2509 sym
= sym_tree
->n
.sym
;
2513 gfc_internal_error ("free_sym_tree(): Negative refs");
2515 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2517 /* As formal_ns contains a reference to sym, delete formal_ns just
2518 before the deletion of sym. */
2519 ns
= sym
->formal_ns
;
2520 sym
->formal_ns
= NULL
;
2521 gfc_free_namespace (ns
);
2523 else if (sym
->refs
== 0)
2525 /* Go ahead and delete the symbol. */
2526 gfc_free_symbol (sym
);
2529 gfc_free (sym_tree
);
2533 /* Free a derived type list. */
2536 gfc_free_dt_list (gfc_dt_list
* dt
)
2548 /* Free the gfc_equiv_info's. */
2551 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2555 gfc_free_equiv_infos (s
->next
);
2560 /* Free the gfc_equiv_lists. */
2563 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2567 gfc_free_equiv_lists (l
->next
);
2568 gfc_free_equiv_infos (l
->equiv
);
2573 /* Free a namespace structure and everything below it. Interface
2574 lists associated with intrinsic operators are not freed. These are
2575 taken care of when a specific name is freed. */
2578 gfc_free_namespace (gfc_namespace
* ns
)
2580 gfc_charlen
*cl
, *cl2
;
2581 gfc_namespace
*p
, *q
;
2590 gcc_assert (ns
->refs
== 0);
2592 gfc_free_statements (ns
->code
);
2594 free_sym_tree (ns
->sym_root
);
2595 free_uop_tree (ns
->uop_root
);
2596 free_common_tree (ns
->common_root
);
2598 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2601 gfc_free_expr (cl
->length
);
2605 free_st_labels (ns
->st_labels
);
2607 gfc_free_equiv (ns
->equiv
);
2608 gfc_free_equiv_lists (ns
->equiv_lists
);
2610 gfc_free_dt_list (ns
->derived_types
);
2612 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2613 gfc_free_interface (ns
->operator[i
]);
2615 gfc_free_data (ns
->data
);
2619 /* Recursively free any contained namespaces. */
2625 gfc_free_namespace (q
);
2631 gfc_symbol_init_2 (void)
2634 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2639 gfc_symbol_done_2 (void)
2642 gfc_free_namespace (gfc_current_ns
);
2643 gfc_current_ns
= NULL
;
2647 /* Clear mark bits from symbol nodes associated with a symtree node. */
2650 clear_sym_mark (gfc_symtree
* st
)
2653 st
->n
.sym
->mark
= 0;
2657 /* Recursively traverse the symtree nodes. */
2660 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2666 gfc_traverse_symtree (st
->left
, func
);
2667 gfc_traverse_symtree (st
->right
, func
);
2672 /* Recursive namespace traversal function. */
2675 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2681 if (st
->n
.sym
->mark
== 0)
2682 (*func
) (st
->n
.sym
);
2683 st
->n
.sym
->mark
= 1;
2685 traverse_ns (st
->left
, func
);
2686 traverse_ns (st
->right
, func
);
2690 /* Call a given function for all symbols in the namespace. We take
2691 care that each gfc_symbol node is called exactly once. */
2694 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2697 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2699 traverse_ns (ns
->sym_root
, func
);
2703 /* Return TRUE if the symbol is an automatic variable. */
2705 gfc_is_var_automatic (gfc_symbol
* sym
)
2707 /* Pointer and allocatable variables are never automatic. */
2708 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2710 /* Check for arrays with non-constant size. */
2711 if (sym
->attr
.dimension
&& sym
->as
2712 && !gfc_is_compile_time_shape (sym
->as
))
2714 /* Check for non-constant length character variables. */
2715 if (sym
->ts
.type
== BT_CHARACTER
2717 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2722 /* Given a symbol, mark it as SAVEd if it is allowed. */
2725 save_symbol (gfc_symbol
* sym
)
2728 if (sym
->attr
.use_assoc
)
2731 if (sym
->attr
.in_common
2733 || sym
->attr
.flavor
!= FL_VARIABLE
)
2735 /* Automatic objects are not saved. */
2736 if (gfc_is_var_automatic (sym
))
2738 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2742 /* Mark those symbols which can be SAVEd as such. */
2745 gfc_save_all (gfc_namespace
* ns
)
2748 gfc_traverse_ns (ns
, save_symbol
);
2753 /* Make sure that no changes to symbols are pending. */
2756 gfc_symbol_state(void) {
2758 if (changed_syms
!= NULL
)
2759 gfc_internal_error("Symbol changes still pending!");
2764 /************** Global symbol handling ************/
2767 /* Search a tree for the global symbol. */
2770 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2776 if (strcmp (symbol
->name
, name
) == 0)
2779 s
= gfc_find_gsymbol (symbol
->left
, name
);
2783 s
= gfc_find_gsymbol (symbol
->right
, name
);
2791 /* Compare two global symbols. Used for managing the BB tree. */
2794 gsym_compare (void * _s1
, void * _s2
)
2796 gfc_gsymbol
*s1
, *s2
;
2798 s1
= (gfc_gsymbol
*)_s1
;
2799 s2
= (gfc_gsymbol
*)_s2
;
2800 return strcmp(s1
->name
, s2
->name
);
2804 /* Get a global symbol, creating it if it doesn't exist. */
2807 gfc_get_gsymbol (const char *name
)
2811 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2815 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2816 s
->type
= GSYM_UNKNOWN
;
2817 s
->name
= gfc_get_string (name
);
2819 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);