1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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
;
94 gfc_dt_list
*gfc_derived_types
;
97 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
99 /* The following static variable indicates whether a particular element has
100 been explicitly set or not. */
102 static int new_flag
[GFC_LETTERS
];
105 /* Handle a correctly parsed IMPLICIT NONE. */
108 gfc_set_implicit_none (void)
112 if (gfc_current_ns
->seen_implicit_none
)
114 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
118 gfc_current_ns
->seen_implicit_none
= 1;
120 for (i
= 0; i
< GFC_LETTERS
; i
++)
122 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
123 gfc_current_ns
->set_flag
[i
] = 1;
128 /* Reset the implicit range flags. */
131 gfc_clear_new_implicit (void)
135 for (i
= 0; i
< GFC_LETTERS
; i
++)
140 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
143 gfc_add_new_implicit_range (int c1
, int c2
)
150 for (i
= c1
; i
<= c2
; i
++)
154 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
166 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
167 the new implicit types back into the existing types will work. */
170 gfc_merge_new_implicit (gfc_typespec
*ts
)
174 if (gfc_current_ns
->seen_implicit_none
)
176 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
180 for (i
= 0; i
< GFC_LETTERS
; i
++)
185 if (gfc_current_ns
->set_flag
[i
])
187 gfc_error ("Letter %c already has an IMPLICIT type at %C",
191 gfc_current_ns
->default_type
[i
] = *ts
;
192 gfc_current_ns
->set_flag
[i
] = 1;
199 /* Given a symbol, return a pointer to the typespec for its default type. */
202 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
206 letter
= sym
->name
[0];
208 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
209 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
210 "gfortran developers, and should not be used for "
211 "implicitly typed variables");
213 if (letter
< 'a' || letter
> 'z')
214 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
219 return &ns
->default_type
[letter
- 'a'];
223 /* Given a pointer to a symbol, set its type according to the first
224 letter of its name. Fails if the letter in question has no default
228 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
232 if (sym
->ts
.type
!= BT_UNKNOWN
)
233 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
235 ts
= gfc_get_default_type (sym
, ns
);
237 if (ts
->type
== BT_UNKNOWN
)
239 if (error_flag
&& !sym
->attr
.untyped
)
241 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
242 sym
->name
, &sym
->declared_at
);
243 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
250 sym
->attr
.implicit_type
= 1;
256 /* This function is called from parse.c(parse_progunit) to check the
257 type of the function is not implicitly typed in the host namespace
258 and to implicitly type the function result, if necessary. */
261 gfc_check_function_type (gfc_namespace
*ns
)
263 gfc_symbol
*proc
= ns
->proc_name
;
265 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
268 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
270 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
273 if (proc
->result
!= proc
)
275 proc
->ts
= proc
->result
->ts
;
276 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
277 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
278 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
279 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
284 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
285 proc
->result
->name
, &proc
->result
->declared_at
);
286 proc
->result
->attr
.untyped
= 1;
292 /******************** Symbol attribute stuff *********************/
294 /* This is a generic conflict-checker. We do this to avoid having a
295 single conflict in two places. */
297 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
298 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
299 #define conf_std(a, b, std) if (attr->a && attr->b)\
308 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
310 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
311 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
312 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
313 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
314 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
315 *private = "PRIVATE", *recursive
= "RECURSIVE",
316 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
317 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
318 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
319 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
320 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
321 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
322 *volatile_
= "VOLATILE", *protected = "PROTECTED";
323 static const char *threadprivate
= "THREADPRIVATE";
329 where
= &gfc_current_locus
;
331 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
335 standard
= GFC_STD_F2003
;
339 /* Check for attributes not allowed in a BLOCK DATA. */
340 if (gfc_current_state () == COMP_BLOCK_DATA
)
344 if (attr
->in_namelist
)
346 if (attr
->allocatable
)
352 if (attr
->access
== ACCESS_PRIVATE
)
354 if (attr
->access
== ACCESS_PUBLIC
)
356 if (attr
->intent
!= INTENT_UNKNOWN
)
362 ("%s attribute not allowed in BLOCK DATA program unit at %L",
369 conf (dummy
, intrinsic
);
371 conf (dummy
, threadprivate
);
372 conf (pointer
, target
);
373 conf (pointer
, external
);
374 conf (pointer
, intrinsic
);
375 conf (pointer
, elemental
);
376 conf (allocatable
, elemental
);
378 conf (target
, external
);
379 conf (target
, intrinsic
);
380 conf (external
, dimension
); /* See Fortran 95's R504. */
382 conf (external
, intrinsic
);
384 if (attr
->if_source
|| attr
->contained
)
386 conf (external
, subroutine
);
387 conf (external
, function
);
390 conf (allocatable
, pointer
);
391 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
392 conf_std (allocatable
, function
, GFC_STD_F2003
);
393 conf_std (allocatable
, result
, GFC_STD_F2003
);
394 conf (elemental
, recursive
);
396 conf (in_common
, dummy
);
397 conf (in_common
, allocatable
);
398 conf (in_common
, result
);
399 conf (in_common
, save
);
402 conf (dummy
, result
);
404 conf (in_equivalence
, use_assoc
);
405 conf (in_equivalence
, dummy
);
406 conf (in_equivalence
, target
);
407 conf (in_equivalence
, pointer
);
408 conf (in_equivalence
, function
);
409 conf (in_equivalence
, result
);
410 conf (in_equivalence
, entry
);
411 conf (in_equivalence
, allocatable
);
412 conf (in_equivalence
, threadprivate
);
414 conf (in_namelist
, pointer
);
415 conf (in_namelist
, allocatable
);
417 conf (entry
, result
);
419 conf (function
, subroutine
);
421 /* Cray pointer/pointee conflicts. */
422 conf (cray_pointer
, cray_pointee
);
423 conf (cray_pointer
, dimension
);
424 conf (cray_pointer
, pointer
);
425 conf (cray_pointer
, target
);
426 conf (cray_pointer
, allocatable
);
427 conf (cray_pointer
, external
);
428 conf (cray_pointer
, intrinsic
);
429 conf (cray_pointer
, in_namelist
);
430 conf (cray_pointer
, function
);
431 conf (cray_pointer
, subroutine
);
432 conf (cray_pointer
, entry
);
434 conf (cray_pointee
, allocatable
);
435 conf (cray_pointee
, intent
);
436 conf (cray_pointee
, optional
);
437 conf (cray_pointee
, dummy
);
438 conf (cray_pointee
, target
);
439 conf (cray_pointee
, intrinsic
);
440 conf (cray_pointee
, pointer
);
441 conf (cray_pointee
, entry
);
442 conf (cray_pointee
, in_common
);
443 conf (cray_pointee
, in_equivalence
);
444 conf (cray_pointee
, threadprivate
);
447 conf (data
, function
);
449 conf (data
, allocatable
);
450 conf (data
, use_assoc
);
452 conf (protected, intrinsic
)
453 conf (protected, external
)
454 conf (protected, in_common
)
456 conf (value
, pointer
)
457 conf (value
, allocatable
)
458 conf (value
, subroutine
)
459 conf (value
, function
)
460 conf (value
, volatile_
)
461 conf (value
, dimension
)
462 conf (value
, external
)
465 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
468 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
472 conf (volatile_
, intrinsic
)
473 conf (volatile_
, external
)
475 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
482 a1
= gfc_code2string (flavors
, attr
->flavor
);
484 if (attr
->in_namelist
485 && attr
->flavor
!= FL_VARIABLE
486 && attr
->flavor
!= FL_PROCEDURE
487 && attr
->flavor
!= FL_UNKNOWN
)
493 switch (attr
->flavor
)
514 conf2 (threadprivate
);
525 if (attr
->subroutine
)
534 conf2 (threadprivate
);
539 case PROC_ST_FUNCTION
:
552 conf2 (threadprivate
);
573 conf2 (threadprivate
);
575 if (attr
->intent
!= INTENT_UNKNOWN
)
598 conf2 (threadprivate
);
609 gfc_error ("%s attribute conflicts with %s attribute at %L",
612 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
613 a1
, a2
, name
, where
);
620 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
621 "with %s attribute at %L", a1
, a2
,
626 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
627 "with %s attribute in '%s' at %L",
628 a1
, a2
, name
, where
);
637 /* Mark a symbol as referenced. */
640 gfc_set_sym_referenced (gfc_symbol
*sym
)
643 if (sym
->attr
.referenced
)
646 sym
->attr
.referenced
= 1;
648 /* Remember which order dummy variables are accessed in. */
650 sym
->dummy_order
= next_dummy_order
++;
654 /* Common subroutine called by attribute changing subroutines in order
655 to prevent them from changing a symbol that has been
656 use-associated. Returns zero if it is OK to change the symbol,
660 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
663 if (attr
->use_assoc
== 0)
667 where
= &gfc_current_locus
;
670 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
673 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
680 /* Generate an error because of a duplicate attribute. */
683 duplicate_attr (const char *attr
, locus
*where
)
687 where
= &gfc_current_locus
;
689 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
693 /* Called from decl.c (attr_decl1) to check attributes, when declared
697 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
700 if (check_used (attr
, NULL
, where
))
703 return check_conflict (attr
, NULL
, where
);
707 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
710 if (check_used (attr
, NULL
, where
))
713 if (attr
->allocatable
)
715 duplicate_attr ("ALLOCATABLE", where
);
719 attr
->allocatable
= 1;
720 return check_conflict (attr
, NULL
, where
);
725 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
728 if (check_used (attr
, name
, where
))
733 duplicate_attr ("DIMENSION", where
);
738 return check_conflict (attr
, name
, where
);
743 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
746 if (check_used (attr
, NULL
, where
))
751 duplicate_attr ("EXTERNAL", where
);
757 return check_conflict (attr
, NULL
, where
);
762 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
765 if (check_used (attr
, NULL
, where
))
770 duplicate_attr ("INTRINSIC", where
);
776 return check_conflict (attr
, NULL
, where
);
781 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
784 if (check_used (attr
, NULL
, where
))
789 duplicate_attr ("OPTIONAL", where
);
794 return check_conflict (attr
, NULL
, where
);
799 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
802 if (check_used (attr
, NULL
, where
))
806 return check_conflict (attr
, NULL
, where
);
811 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
814 if (check_used (attr
, NULL
, where
))
817 attr
->cray_pointer
= 1;
818 return check_conflict (attr
, NULL
, where
);
823 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
826 if (check_used (attr
, NULL
, where
))
829 if (attr
->cray_pointee
)
831 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
832 " statements", where
);
836 attr
->cray_pointee
= 1;
837 return check_conflict (attr
, NULL
, where
);
842 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
844 if (check_used (attr
, name
, where
))
849 if (gfc_notify_std (GFC_STD_LEGACY
,
850 "Duplicate PROTECTED attribute specified at %L",
857 return check_conflict (attr
, name
, where
);
862 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
865 if (check_used (attr
, name
, where
))
869 return check_conflict (attr
, name
, where
);
874 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
877 if (check_used (attr
, name
, where
))
883 ("SAVE attribute at %L cannot be specified in a PURE procedure",
890 if (gfc_notify_std (GFC_STD_LEGACY
,
891 "Duplicate SAVE attribute specified at %L",
898 return check_conflict (attr
, name
, where
);
903 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
906 if (check_used (attr
, name
, where
))
911 if (gfc_notify_std (GFC_STD_LEGACY
,
912 "Duplicate VALUE attribute specified at %L",
919 return check_conflict (attr
, name
, where
);
924 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
926 /* No check_used needed as 11.2.1 of the F2003 standard allows
927 that the local identifier made accessible by a use statement can be
928 given a VOLATILE attribute. */
930 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
931 if (gfc_notify_std (GFC_STD_LEGACY
,
932 "Duplicate VOLATILE attribute specified at %L", where
)
937 attr
->volatile_ns
= gfc_current_ns
;
938 return check_conflict (attr
, name
, where
);
943 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
946 if (check_used (attr
, name
, where
))
949 if (attr
->threadprivate
)
951 duplicate_attr ("THREADPRIVATE", where
);
955 attr
->threadprivate
= 1;
956 return check_conflict (attr
, name
, where
);
961 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
964 if (check_used (attr
, NULL
, where
))
969 duplicate_attr ("TARGET", where
);
974 return check_conflict (attr
, NULL
, where
);
979 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
982 if (check_used (attr
, name
, where
))
985 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
987 return check_conflict (attr
, name
, where
);
992 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
995 if (check_used (attr
, name
, where
))
998 /* Duplicate attribute already checked for. */
1000 if (check_conflict (attr
, name
, where
) == FAILURE
)
1003 if (attr
->flavor
== FL_VARIABLE
)
1006 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1011 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1014 /* Duplicate attribute already checked for. */
1015 attr
->in_equivalence
= 1;
1016 if (check_conflict (attr
, name
, where
) == FAILURE
)
1019 if (attr
->flavor
== FL_VARIABLE
)
1022 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1027 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1030 if (check_used (attr
, name
, where
))
1034 return check_conflict (attr
, name
, where
);
1039 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1042 attr
->in_namelist
= 1;
1043 return check_conflict (attr
, name
, where
);
1048 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1051 if (check_used (attr
, name
, where
))
1055 return check_conflict (attr
, name
, where
);
1060 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1063 if (check_used (attr
, NULL
, where
))
1066 attr
->elemental
= 1;
1067 return check_conflict (attr
, NULL
, where
);
1072 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1075 if (check_used (attr
, NULL
, where
))
1079 return check_conflict (attr
, NULL
, where
);
1084 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1087 if (check_used (attr
, NULL
, where
))
1090 attr
->recursive
= 1;
1091 return check_conflict (attr
, NULL
, where
);
1096 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1099 if (check_used (attr
, name
, where
))
1104 duplicate_attr ("ENTRY", where
);
1109 return check_conflict (attr
, name
, where
);
1114 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1117 if (attr
->flavor
!= FL_PROCEDURE
1118 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1122 return check_conflict (attr
, name
, where
);
1127 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1130 if (attr
->flavor
!= FL_PROCEDURE
1131 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1134 attr
->subroutine
= 1;
1135 return check_conflict (attr
, name
, where
);
1140 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1143 if (attr
->flavor
!= FL_PROCEDURE
1144 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1148 return check_conflict (attr
, name
, where
);
1152 /* Flavors are special because some flavors are not what Fortran
1153 considers attributes and can be reaffirmed multiple times. */
1156 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1160 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1161 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1162 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1165 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1168 if (attr
->flavor
!= FL_UNKNOWN
)
1171 where
= &gfc_current_locus
;
1174 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1175 gfc_code2string (flavors
, attr
->flavor
), name
,
1176 gfc_code2string (flavors
, f
), where
);
1178 gfc_error ("%s attribute conflicts with %s attribute at %L",
1179 gfc_code2string (flavors
, attr
->flavor
),
1180 gfc_code2string (flavors
, f
), where
);
1187 return check_conflict (attr
, name
, where
);
1192 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1193 const char *name
, locus
*where
)
1196 if (check_used (attr
, name
, where
))
1199 if (attr
->flavor
!= FL_PROCEDURE
1200 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1204 where
= &gfc_current_locus
;
1206 if (attr
->proc
!= PROC_UNKNOWN
)
1208 gfc_error ("%s procedure at %L is already declared as %s procedure",
1209 gfc_code2string (procedures
, t
), where
,
1210 gfc_code2string (procedures
, attr
->proc
));
1217 /* Statement functions are always scalar and functions. */
1218 if (t
== PROC_ST_FUNCTION
1219 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1220 || attr
->dimension
))
1223 return check_conflict (attr
, name
, where
);
1228 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1231 if (check_used (attr
, NULL
, where
))
1234 if (attr
->intent
== INTENT_UNKNOWN
)
1236 attr
->intent
= intent
;
1237 return check_conflict (attr
, NULL
, where
);
1241 where
= &gfc_current_locus
;
1243 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1244 gfc_intent_string (attr
->intent
),
1245 gfc_intent_string (intent
), where
);
1251 /* No checks for use-association in public and private statements. */
1254 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1255 const char *name
, locus
*where
)
1258 if (attr
->access
== ACCESS_UNKNOWN
)
1260 attr
->access
= access
;
1261 return check_conflict (attr
, name
, where
);
1265 where
= &gfc_current_locus
;
1266 gfc_error ("ACCESS specification at %L was already specified", where
);
1273 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1274 gfc_formal_arglist
* formal
, locus
* where
)
1277 if (check_used (&sym
->attr
, sym
->name
, where
))
1281 where
= &gfc_current_locus
;
1283 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1284 && sym
->attr
.if_source
!= IFSRC_DECL
)
1286 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1291 sym
->formal
= formal
;
1292 sym
->attr
.if_source
= source
;
1298 /* Add a type to a symbol. */
1301 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1306 where
= &gfc_current_locus
;
1308 if (sym
->ts
.type
!= BT_UNKNOWN
)
1310 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1311 if (!(sym
->ts
.type
== ts
->type
1312 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1313 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1316 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1319 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1320 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1324 flavor
= sym
->attr
.flavor
;
1326 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1327 || flavor
== FL_LABEL
1328 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1329 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1331 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1340 /* Clears all attributes. */
1343 gfc_clear_attr (symbol_attribute
*attr
)
1345 memset (attr
, 0, sizeof (symbol_attribute
));
1349 /* Check for missing attributes in the new symbol. Currently does
1350 nothing, but it's not clear that it is unnecessary yet. */
1353 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1354 locus
*where ATTRIBUTE_UNUSED
)
1361 /* Copy an attribute to a symbol attribute, bit by bit. Some
1362 attributes have a lot of side-effects but cannot be present given
1363 where we are called from, so we ignore some bits. */
1366 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1369 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1372 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1374 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1376 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1378 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1380 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1382 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1384 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1386 if (src
->threadprivate
1387 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1389 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1391 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1393 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1398 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1401 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1404 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1406 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1408 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1411 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1413 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1415 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1417 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1420 if (src
->flavor
!= FL_UNKNOWN
1421 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1424 if (src
->intent
!= INTENT_UNKNOWN
1425 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1428 if (src
->access
!= ACCESS_UNKNOWN
1429 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1432 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1435 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1437 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1440 /* The subroutines that set these bits also cause flavors to be set,
1441 and that has already happened in the original, so don't let it
1446 dest
->intrinsic
= 1;
1455 /************** Component name management ************/
1457 /* Component names of a derived type form their own little namespaces
1458 that are separate from all other spaces. The space is composed of
1459 a singly linked list of gfc_component structures whose head is
1460 located in the parent symbol. */
1463 /* Add a component name to a symbol. The call fails if the name is
1464 already present. On success, the component pointer is modified to
1465 point to the additional component structure. */
1468 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1469 gfc_component
**component
)
1471 gfc_component
*p
, *tail
;
1475 for (p
= sym
->components
; p
; p
= p
->next
)
1477 if (strcmp (p
->name
, name
) == 0)
1479 gfc_error ("Component '%s' at %C already declared at %L",
1487 /* Allocate a new component. */
1488 p
= gfc_get_component ();
1491 sym
->components
= p
;
1495 p
->name
= gfc_get_string (name
);
1496 p
->loc
= gfc_current_locus
;
1503 /* Recursive function to switch derived types of all symbol in a
1507 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1515 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1516 sym
->ts
.derived
= to
;
1518 switch_types (st
->left
, from
, to
);
1519 switch_types (st
->right
, from
, to
);
1523 /* This subroutine is called when a derived type is used in order to
1524 make the final determination about which version to use. The
1525 standard requires that a type be defined before it is 'used', but
1526 such types can appear in IMPLICIT statements before the actual
1527 definition. 'Using' in this context means declaring a variable to
1528 be that type or using the type constructor.
1530 If a type is used and the components haven't been defined, then we
1531 have to have a derived type in a parent unit. We find the node in
1532 the other namespace and point the symtree node in this namespace to
1533 that node. Further reference to this name point to the correct
1534 node. If we can't find the node in a parent namespace, then we have
1537 This subroutine takes a pointer to a symbol node and returns a
1538 pointer to the translated node or NULL for an error. Usually there
1539 is no translation and we return the node we were passed. */
1542 gfc_use_derived (gfc_symbol
*sym
)
1549 if (sym
->components
!= NULL
)
1550 return sym
; /* Already defined. */
1552 if (sym
->ns
->parent
== NULL
)
1555 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1557 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1561 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1564 /* Get rid of symbol sym, translating all references to s. */
1565 for (i
= 0; i
< GFC_LETTERS
; i
++)
1567 t
= &sym
->ns
->default_type
[i
];
1568 if (t
->derived
== sym
)
1572 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1577 /* Unlink from list of modified symbols. */
1578 gfc_commit_symbol (sym
);
1580 switch_types (sym
->ns
->sym_root
, sym
, s
);
1582 /* TODO: Also have to replace sym -> s in other lists like
1583 namelists, common lists and interface lists. */
1584 gfc_free_symbol (sym
);
1589 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1595 /* Given a derived type node and a component name, try to locate the
1596 component structure. Returns the NULL pointer if the component is
1597 not found or the components are private. */
1600 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1607 sym
= gfc_use_derived (sym
);
1612 for (p
= sym
->components
; p
; p
= p
->next
)
1613 if (strcmp (p
->name
, name
) == 0)
1617 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1621 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1623 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1633 /* Given a symbol, free all of the component structures and everything
1637 free_components (gfc_component
*p
)
1645 gfc_free_array_spec (p
->as
);
1646 gfc_free_expr (p
->initializer
);
1653 /* Set component attributes from a standard symbol attribute structure. */
1656 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1659 c
->dimension
= attr
->dimension
;
1660 c
->pointer
= attr
->pointer
;
1661 c
->allocatable
= attr
->allocatable
;
1665 /* Get a standard symbol attribute structure given the component
1669 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1672 gfc_clear_attr (attr
);
1673 attr
->dimension
= c
->dimension
;
1674 attr
->pointer
= c
->pointer
;
1675 attr
->allocatable
= c
->allocatable
;
1679 /******************** Statement label management ********************/
1681 /* Comparison function for statement labels, used for managing the
1685 compare_st_labels (void *a1
, void *b1
)
1687 int a
= ((gfc_st_label
*) a1
)->value
;
1688 int b
= ((gfc_st_label
*) b1
)->value
;
1694 /* Free a single gfc_st_label structure, making sure the tree is not
1695 messed up. This function is called only when some parse error
1699 gfc_free_st_label (gfc_st_label
*label
)
1705 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1707 if (label
->format
!= NULL
)
1708 gfc_free_expr (label
->format
);
1714 /* Free a whole tree of gfc_st_label structures. */
1717 free_st_labels (gfc_st_label
*label
)
1723 free_st_labels (label
->left
);
1724 free_st_labels (label
->right
);
1726 if (label
->format
!= NULL
)
1727 gfc_free_expr (label
->format
);
1732 /* Given a label number, search for and return a pointer to the label
1733 structure, creating it if it does not exist. */
1736 gfc_get_st_label (int labelno
)
1740 /* First see if the label is already in this namespace. */
1741 lp
= gfc_current_ns
->st_labels
;
1744 if (lp
->value
== labelno
)
1747 if (lp
->value
< labelno
)
1753 lp
= gfc_getmem (sizeof (gfc_st_label
));
1755 lp
->value
= labelno
;
1756 lp
->defined
= ST_LABEL_UNKNOWN
;
1757 lp
->referenced
= ST_LABEL_UNKNOWN
;
1759 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1765 /* Called when a statement with a statement label is about to be
1766 accepted. We add the label to the list of the current namespace,
1767 making sure it hasn't been defined previously and referenced
1771 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1775 labelno
= lp
->value
;
1777 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1778 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1779 &lp
->where
, label_locus
);
1782 lp
->where
= *label_locus
;
1786 case ST_LABEL_FORMAT
:
1787 if (lp
->referenced
== ST_LABEL_TARGET
)
1788 gfc_error ("Label %d at %C already referenced as branch target",
1791 lp
->defined
= ST_LABEL_FORMAT
;
1795 case ST_LABEL_TARGET
:
1796 if (lp
->referenced
== ST_LABEL_FORMAT
)
1797 gfc_error ("Label %d at %C already referenced as a format label",
1800 lp
->defined
= ST_LABEL_TARGET
;
1805 lp
->defined
= ST_LABEL_BAD_TARGET
;
1806 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1812 /* Reference a label. Given a label and its type, see if that
1813 reference is consistent with what is known about that label,
1814 updating the unknown state. Returns FAILURE if something goes
1818 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1820 gfc_sl_type label_type
;
1827 labelno
= lp
->value
;
1829 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1830 label_type
= lp
->defined
;
1833 label_type
= lp
->referenced
;
1834 lp
->where
= gfc_current_locus
;
1837 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1839 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1844 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1845 && type
== ST_LABEL_FORMAT
)
1847 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1852 lp
->referenced
= type
;
1860 /************** Symbol table management subroutines ****************/
1862 /* Basic details: Fortran 95 requires a potentially unlimited number
1863 of distinct namespaces when compiling a program unit. This case
1864 occurs during a compilation of internal subprograms because all of
1865 the internal subprograms must be read before we can start
1866 generating code for the host.
1868 Given the tricky nature of the Fortran grammar, we must be able to
1869 undo changes made to a symbol table if the current interpretation
1870 of a statement is found to be incorrect. Whenever a symbol is
1871 looked up, we make a copy of it and link to it. All of these
1872 symbols are kept in a singly linked list so that we can commit or
1873 undo the changes at a later time.
1875 A symtree may point to a symbol node outside of its namespace. In
1876 this case, that symbol has been used as a host associated variable
1877 at some previous time. */
1879 /* Allocate a new namespace structure. Copies the implicit types from
1880 PARENT if PARENT_TYPES is set. */
1883 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
1887 gfc_intrinsic_op in
;
1890 ns
= gfc_getmem (sizeof (gfc_namespace
));
1891 ns
->sym_root
= NULL
;
1892 ns
->uop_root
= NULL
;
1893 ns
->default_access
= ACCESS_UNKNOWN
;
1894 ns
->parent
= parent
;
1896 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1897 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1899 /* Initialize default implicit types. */
1900 for (i
= 'a'; i
<= 'z'; i
++)
1902 ns
->set_flag
[i
- 'a'] = 0;
1903 ts
= &ns
->default_type
[i
- 'a'];
1905 if (parent_types
&& ns
->parent
!= NULL
)
1907 /* Copy parent settings. */
1908 *ts
= ns
->parent
->default_type
[i
- 'a'];
1912 if (gfc_option
.flag_implicit_none
!= 0)
1918 if ('i' <= i
&& i
<= 'n')
1920 ts
->type
= BT_INTEGER
;
1921 ts
->kind
= gfc_default_integer_kind
;
1926 ts
->kind
= gfc_default_real_kind
;
1936 /* Comparison function for symtree nodes. */
1939 compare_symtree (void *_st1
, void *_st2
)
1941 gfc_symtree
*st1
, *st2
;
1943 st1
= (gfc_symtree
*) _st1
;
1944 st2
= (gfc_symtree
*) _st2
;
1946 return strcmp (st1
->name
, st2
->name
);
1950 /* Allocate a new symtree node and associate it with the new symbol. */
1953 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
1957 st
= gfc_getmem (sizeof (gfc_symtree
));
1958 st
->name
= gfc_get_string (name
);
1960 gfc_insert_bbt (root
, st
, compare_symtree
);
1965 /* Delete a symbol from the tree. Does not free the symbol itself! */
1968 delete_symtree (gfc_symtree
**root
, const char *name
)
1970 gfc_symtree st
, *st0
;
1972 st0
= gfc_find_symtree (*root
, name
);
1974 st
.name
= gfc_get_string (name
);
1975 gfc_delete_bbt (root
, &st
, compare_symtree
);
1981 /* Given a root symtree node and a name, try to find the symbol within
1982 the namespace. Returns NULL if the symbol is not found. */
1985 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
1991 c
= strcmp (name
, st
->name
);
1995 st
= (c
< 0) ? st
->left
: st
->right
;
2002 /* Given a name find a user operator node, creating it if it doesn't
2003 exist. These are much simpler than symbols because they can't be
2004 ambiguous with one another. */
2007 gfc_get_uop (const char *name
)
2012 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2016 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2018 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2019 uop
->name
= gfc_get_string (name
);
2020 uop
->access
= ACCESS_UNKNOWN
;
2021 uop
->ns
= gfc_current_ns
;
2027 /* Given a name find the user operator node. Returns NULL if it does
2031 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2036 ns
= gfc_current_ns
;
2038 st
= gfc_find_symtree (ns
->uop_root
, name
);
2039 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2043 /* Remove a gfc_symbol structure and everything it points to. */
2046 gfc_free_symbol (gfc_symbol
*sym
)
2052 gfc_free_array_spec (sym
->as
);
2054 free_components (sym
->components
);
2056 gfc_free_expr (sym
->value
);
2058 gfc_free_namelist (sym
->namelist
);
2060 gfc_free_namespace (sym
->formal_ns
);
2062 if (!sym
->attr
.generic_copy
)
2063 gfc_free_interface (sym
->generic
);
2065 gfc_free_formal_arglist (sym
->formal
);
2071 /* Allocate and initialize a new symbol node. */
2074 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2078 p
= gfc_getmem (sizeof (gfc_symbol
));
2080 gfc_clear_ts (&p
->ts
);
2081 gfc_clear_attr (&p
->attr
);
2084 p
->declared_at
= gfc_current_locus
;
2086 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2087 gfc_internal_error ("new_symbol(): Symbol name too long");
2089 p
->name
= gfc_get_string (name
);
2094 /* Generate an error if a symbol is ambiguous. */
2097 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2100 if (st
->n
.sym
->module
)
2101 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2102 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2104 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2105 "from current program unit", name
, st
->n
.sym
->name
);
2109 /* Search for a symtree starting in the current namespace, resorting to
2110 any parent namespaces if requested by a nonzero parent_flag.
2111 Returns nonzero if the name is ambiguous. */
2114 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2115 gfc_symtree
**result
)
2120 ns
= gfc_current_ns
;
2124 st
= gfc_find_symtree (ns
->sym_root
, name
);
2128 /* Ambiguous generic interfaces are permitted, as long
2129 as the specific interfaces are different. */
2130 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2132 ambiguous_symbol (name
, st
);
2151 /* Same, but returns the symbol instead. */
2154 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2155 gfc_symbol
**result
)
2160 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2165 *result
= st
->n
.sym
;
2171 /* Save symbol with the information necessary to back it out. */
2174 save_symbol_data (gfc_symbol
*sym
)
2177 if (sym
->new || sym
->old_symbol
!= NULL
)
2180 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2181 *(sym
->old_symbol
) = *sym
;
2183 sym
->tlink
= changed_syms
;
2188 /* Given a name, find a symbol, or create it if it does not exist yet
2189 in the current namespace. If the symbol is found we make sure that
2192 The integer return code indicates
2194 1 The symbol name was ambiguous
2195 2 The name meant to be established was already host associated.
2197 So if the return value is nonzero, then an error was issued. */
2200 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2205 /* This doesn't usually happen during resolution. */
2207 ns
= gfc_current_ns
;
2209 /* Try to find the symbol in ns. */
2210 st
= gfc_find_symtree (ns
->sym_root
, name
);
2214 /* If not there, create a new symbol. */
2215 p
= gfc_new_symbol (name
, ns
);
2217 /* Add to the list of tentative symbols. */
2218 p
->old_symbol
= NULL
;
2219 p
->tlink
= changed_syms
;
2224 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2231 /* Make sure the existing symbol is OK. Ambiguous
2232 generic interfaces are permitted, as long as the
2233 specific interfaces are different. */
2234 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2236 ambiguous_symbol (name
, st
);
2242 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2244 /* Symbol is from another namespace. */
2245 gfc_error ("Symbol '%s' at %C has already been host associated",
2252 /* Copy in case this symbol is changed. */
2253 save_symbol_data (p
);
2262 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2267 i
= gfc_get_sym_tree (name
, ns
, &st
);
2272 *result
= st
->n
.sym
;
2279 /* Subroutine that searches for a symbol, creating it if it doesn't
2280 exist, but tries to host-associate the symbol if possible. */
2283 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2288 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2291 save_symbol_data (st
->n
.sym
);
2296 if (gfc_current_ns
->parent
!= NULL
)
2298 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2309 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2314 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2319 i
= gfc_get_ha_sym_tree (name
, &st
);
2322 *result
= st
->n
.sym
;
2329 /* Return true if both symbols could refer to the same data object. Does
2330 not take account of aliasing due to equivalence statements. */
2333 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2335 /* Aliasing isn't possible if the symbols have different base types. */
2336 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2339 /* Pointers can point to other pointers, target objects and allocatable
2340 objects. Two allocatable objects cannot share the same storage. */
2341 if (lsym
->attr
.pointer
2342 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2344 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2346 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2353 /* Undoes all the changes made to symbols in the current statement.
2354 This subroutine is made simpler due to the fact that attributes are
2355 never removed once added. */
2358 gfc_undo_symbols (void)
2360 gfc_symbol
*p
, *q
, *old
;
2362 for (p
= changed_syms
; p
; p
= q
)
2368 /* Symbol was new. */
2369 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2373 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2375 gfc_free_symbol (p
);
2379 /* Restore previous state of symbol. Just copy simple stuff. */
2381 old
= p
->old_symbol
;
2383 p
->ts
.type
= old
->ts
.type
;
2384 p
->ts
.kind
= old
->ts
.kind
;
2386 p
->attr
= old
->attr
;
2388 if (p
->value
!= old
->value
)
2390 gfc_free_expr (old
->value
);
2394 if (p
->as
!= old
->as
)
2397 gfc_free_array_spec (p
->as
);
2401 p
->generic
= old
->generic
;
2402 p
->component_access
= old
->component_access
;
2404 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2406 gfc_free_namelist (p
->namelist
);
2411 if (p
->namelist_tail
!= old
->namelist_tail
)
2413 gfc_free_namelist (old
->namelist_tail
);
2414 old
->namelist_tail
->next
= NULL
;
2418 p
->namelist_tail
= old
->namelist_tail
;
2420 if (p
->formal
!= old
->formal
)
2422 gfc_free_formal_arglist (p
->formal
);
2423 p
->formal
= old
->formal
;
2426 gfc_free (p
->old_symbol
);
2427 p
->old_symbol
= NULL
;
2431 changed_syms
= NULL
;
2435 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2436 components of old_symbol that might need deallocation are the "allocatables"
2437 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2438 namelist_tail. In case these differ between old_symbol and sym, it's just
2439 because sym->namelist has gotten a few more items. */
2442 free_old_symbol (gfc_symbol
*sym
)
2445 if (sym
->old_symbol
== NULL
)
2448 if (sym
->old_symbol
->as
!= sym
->as
)
2449 gfc_free_array_spec (sym
->old_symbol
->as
);
2451 if (sym
->old_symbol
->value
!= sym
->value
)
2452 gfc_free_expr (sym
->old_symbol
->value
);
2454 if (sym
->old_symbol
->formal
!= sym
->formal
)
2455 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2457 gfc_free (sym
->old_symbol
);
2458 sym
->old_symbol
= NULL
;
2462 /* Makes the changes made in the current statement permanent-- gets
2463 rid of undo information. */
2466 gfc_commit_symbols (void)
2470 for (p
= changed_syms
; p
; p
= q
)
2476 free_old_symbol (p
);
2478 changed_syms
= NULL
;
2482 /* Makes the changes made in one symbol permanent -- gets rid of undo
2486 gfc_commit_symbol (gfc_symbol
*sym
)
2490 if (changed_syms
== sym
)
2491 changed_syms
= sym
->tlink
;
2494 for (p
= changed_syms
; p
; p
= p
->tlink
)
2495 if (p
->tlink
== sym
)
2497 p
->tlink
= sym
->tlink
;
2506 free_old_symbol (sym
);
2510 /* Recursive function that deletes an entire tree and all the common
2511 head structures it points to. */
2514 free_common_tree (gfc_symtree
* common_tree
)
2516 if (common_tree
== NULL
)
2519 free_common_tree (common_tree
->left
);
2520 free_common_tree (common_tree
->right
);
2522 gfc_free (common_tree
);
2526 /* Recursive function that deletes an entire tree and all the user
2527 operator nodes that it contains. */
2530 free_uop_tree (gfc_symtree
*uop_tree
)
2533 if (uop_tree
== NULL
)
2536 free_uop_tree (uop_tree
->left
);
2537 free_uop_tree (uop_tree
->right
);
2539 gfc_free_interface (uop_tree
->n
.uop
->operator);
2541 gfc_free (uop_tree
->n
.uop
);
2542 gfc_free (uop_tree
);
2546 /* Recursive function that deletes an entire tree and all the symbols
2547 that it contains. */
2550 free_sym_tree (gfc_symtree
*sym_tree
)
2555 if (sym_tree
== NULL
)
2558 free_sym_tree (sym_tree
->left
);
2559 free_sym_tree (sym_tree
->right
);
2561 sym
= sym_tree
->n
.sym
;
2565 gfc_internal_error ("free_sym_tree(): Negative refs");
2567 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2569 /* As formal_ns contains a reference to sym, delete formal_ns just
2570 before the deletion of sym. */
2571 ns
= sym
->formal_ns
;
2572 sym
->formal_ns
= NULL
;
2573 gfc_free_namespace (ns
);
2575 else if (sym
->refs
== 0)
2577 /* Go ahead and delete the symbol. */
2578 gfc_free_symbol (sym
);
2581 gfc_free (sym_tree
);
2585 /* Free the derived type list. */
2588 gfc_free_dt_list (void)
2590 gfc_dt_list
*dt
, *n
;
2592 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2598 gfc_derived_types
= NULL
;
2602 /* Free the gfc_equiv_info's. */
2605 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2609 gfc_free_equiv_infos (s
->next
);
2614 /* Free the gfc_equiv_lists. */
2617 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2621 gfc_free_equiv_lists (l
->next
);
2622 gfc_free_equiv_infos (l
->equiv
);
2627 /* Free a namespace structure and everything below it. Interface
2628 lists associated with intrinsic operators are not freed. These are
2629 taken care of when a specific name is freed. */
2632 gfc_free_namespace (gfc_namespace
*ns
)
2634 gfc_charlen
*cl
, *cl2
;
2635 gfc_namespace
*p
, *q
;
2644 gcc_assert (ns
->refs
== 0);
2646 gfc_free_statements (ns
->code
);
2648 free_sym_tree (ns
->sym_root
);
2649 free_uop_tree (ns
->uop_root
);
2650 free_common_tree (ns
->common_root
);
2652 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2655 gfc_free_expr (cl
->length
);
2659 free_st_labels (ns
->st_labels
);
2661 gfc_free_equiv (ns
->equiv
);
2662 gfc_free_equiv_lists (ns
->equiv_lists
);
2664 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2665 gfc_free_interface (ns
->operator[i
]);
2667 gfc_free_data (ns
->data
);
2671 /* Recursively free any contained namespaces. */
2676 gfc_free_namespace (q
);
2682 gfc_symbol_init_2 (void)
2685 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2690 gfc_symbol_done_2 (void)
2693 gfc_free_namespace (gfc_current_ns
);
2694 gfc_current_ns
= NULL
;
2695 gfc_free_dt_list ();
2699 /* Clear mark bits from symbol nodes associated with a symtree node. */
2702 clear_sym_mark (gfc_symtree
*st
)
2705 st
->n
.sym
->mark
= 0;
2709 /* Recursively traverse the symtree nodes. */
2712 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2718 gfc_traverse_symtree (st
->left
, func
);
2719 gfc_traverse_symtree (st
->right
, func
);
2724 /* Recursive namespace traversal function. */
2727 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2733 if (st
->n
.sym
->mark
== 0)
2734 (*func
) (st
->n
.sym
);
2735 st
->n
.sym
->mark
= 1;
2737 traverse_ns (st
->left
, func
);
2738 traverse_ns (st
->right
, func
);
2742 /* Call a given function for all symbols in the namespace. We take
2743 care that each gfc_symbol node is called exactly once. */
2746 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2749 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2751 traverse_ns (ns
->sym_root
, func
);
2755 /* Return TRUE if the symbol is an automatic variable. */
2758 gfc_is_var_automatic (gfc_symbol
*sym
)
2760 /* Pointer and allocatable variables are never automatic. */
2761 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2763 /* Check for arrays with non-constant size. */
2764 if (sym
->attr
.dimension
&& sym
->as
2765 && !gfc_is_compile_time_shape (sym
->as
))
2767 /* Check for non-constant length character variables. */
2768 if (sym
->ts
.type
== BT_CHARACTER
2770 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2775 /* Given a symbol, mark it as SAVEd if it is allowed. */
2778 save_symbol (gfc_symbol
*sym
)
2781 if (sym
->attr
.use_assoc
)
2784 if (sym
->attr
.in_common
2786 || sym
->attr
.flavor
!= FL_VARIABLE
)
2788 /* Automatic objects are not saved. */
2789 if (gfc_is_var_automatic (sym
))
2791 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2795 /* Mark those symbols which can be SAVEd as such. */
2798 gfc_save_all (gfc_namespace
*ns
)
2801 gfc_traverse_ns (ns
, save_symbol
);
2806 /* Make sure that no changes to symbols are pending. */
2809 gfc_symbol_state(void) {
2811 if (changed_syms
!= NULL
)
2812 gfc_internal_error("Symbol changes still pending!");
2817 /************** Global symbol handling ************/
2820 /* Search a tree for the global symbol. */
2823 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2832 c
= strcmp (name
, symbol
->name
);
2836 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2843 /* Compare two global symbols. Used for managing the BB tree. */
2846 gsym_compare (void *_s1
, void *_s2
)
2848 gfc_gsymbol
*s1
, *s2
;
2850 s1
= (gfc_gsymbol
*) _s1
;
2851 s2
= (gfc_gsymbol
*) _s2
;
2852 return strcmp (s1
->name
, s2
->name
);
2856 /* Get a global symbol, creating it if it doesn't exist. */
2859 gfc_get_gsymbol (const char *name
)
2863 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2867 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2868 s
->type
= GSYM_UNKNOWN
;
2869 s
->name
= gfc_get_string (name
);
2871 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);