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 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1442 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1452 /************** Component name management ************/
1454 /* Component names of a derived type form their own little namespaces
1455 that are separate from all other spaces. The space is composed of
1456 a singly linked list of gfc_component structures whose head is
1457 located in the parent symbol. */
1460 /* Add a component name to a symbol. The call fails if the name is
1461 already present. On success, the component pointer is modified to
1462 point to the additional component structure. */
1465 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1466 gfc_component
**component
)
1468 gfc_component
*p
, *tail
;
1472 for (p
= sym
->components
; p
; p
= p
->next
)
1474 if (strcmp (p
->name
, name
) == 0)
1476 gfc_error ("Component '%s' at %C already declared at %L",
1484 /* Allocate a new component. */
1485 p
= gfc_get_component ();
1488 sym
->components
= p
;
1492 p
->name
= gfc_get_string (name
);
1493 p
->loc
= gfc_current_locus
;
1500 /* Recursive function to switch derived types of all symbol in a
1504 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1512 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1513 sym
->ts
.derived
= to
;
1515 switch_types (st
->left
, from
, to
);
1516 switch_types (st
->right
, from
, to
);
1520 /* This subroutine is called when a derived type is used in order to
1521 make the final determination about which version to use. The
1522 standard requires that a type be defined before it is 'used', but
1523 such types can appear in IMPLICIT statements before the actual
1524 definition. 'Using' in this context means declaring a variable to
1525 be that type or using the type constructor.
1527 If a type is used and the components haven't been defined, then we
1528 have to have a derived type in a parent unit. We find the node in
1529 the other namespace and point the symtree node in this namespace to
1530 that node. Further reference to this name point to the correct
1531 node. If we can't find the node in a parent namespace, then we have
1534 This subroutine takes a pointer to a symbol node and returns a
1535 pointer to the translated node or NULL for an error. Usually there
1536 is no translation and we return the node we were passed. */
1539 gfc_use_derived (gfc_symbol
*sym
)
1546 if (sym
->components
!= NULL
)
1547 return sym
; /* Already defined. */
1549 if (sym
->ns
->parent
== NULL
)
1552 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1554 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1558 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1561 /* Get rid of symbol sym, translating all references to s. */
1562 for (i
= 0; i
< GFC_LETTERS
; i
++)
1564 t
= &sym
->ns
->default_type
[i
];
1565 if (t
->derived
== sym
)
1569 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1574 /* Unlink from list of modified symbols. */
1575 gfc_commit_symbol (sym
);
1577 switch_types (sym
->ns
->sym_root
, sym
, s
);
1579 /* TODO: Also have to replace sym -> s in other lists like
1580 namelists, common lists and interface lists. */
1581 gfc_free_symbol (sym
);
1586 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1592 /* Given a derived type node and a component name, try to locate the
1593 component structure. Returns the NULL pointer if the component is
1594 not found or the components are private. */
1597 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1604 sym
= gfc_use_derived (sym
);
1609 for (p
= sym
->components
; p
; p
= p
->next
)
1610 if (strcmp (p
->name
, name
) == 0)
1614 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1618 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1620 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1630 /* Given a symbol, free all of the component structures and everything
1634 free_components (gfc_component
*p
)
1642 gfc_free_array_spec (p
->as
);
1643 gfc_free_expr (p
->initializer
);
1650 /* Set component attributes from a standard symbol attribute structure. */
1653 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1656 c
->dimension
= attr
->dimension
;
1657 c
->pointer
= attr
->pointer
;
1658 c
->allocatable
= attr
->allocatable
;
1662 /* Get a standard symbol attribute structure given the component
1666 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1669 gfc_clear_attr (attr
);
1670 attr
->dimension
= c
->dimension
;
1671 attr
->pointer
= c
->pointer
;
1672 attr
->allocatable
= c
->allocatable
;
1676 /******************** Statement label management ********************/
1678 /* Comparison function for statement labels, used for managing the
1682 compare_st_labels (void *a1
, void *b1
)
1684 int a
= ((gfc_st_label
*) a1
)->value
;
1685 int b
= ((gfc_st_label
*) b1
)->value
;
1691 /* Free a single gfc_st_label structure, making sure the tree is not
1692 messed up. This function is called only when some parse error
1696 gfc_free_st_label (gfc_st_label
*label
)
1702 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1704 if (label
->format
!= NULL
)
1705 gfc_free_expr (label
->format
);
1711 /* Free a whole tree of gfc_st_label structures. */
1714 free_st_labels (gfc_st_label
*label
)
1720 free_st_labels (label
->left
);
1721 free_st_labels (label
->right
);
1723 if (label
->format
!= NULL
)
1724 gfc_free_expr (label
->format
);
1729 /* Given a label number, search for and return a pointer to the label
1730 structure, creating it if it does not exist. */
1733 gfc_get_st_label (int labelno
)
1737 /* First see if the label is already in this namespace. */
1738 lp
= gfc_current_ns
->st_labels
;
1741 if (lp
->value
== labelno
)
1744 if (lp
->value
< labelno
)
1750 lp
= gfc_getmem (sizeof (gfc_st_label
));
1752 lp
->value
= labelno
;
1753 lp
->defined
= ST_LABEL_UNKNOWN
;
1754 lp
->referenced
= ST_LABEL_UNKNOWN
;
1756 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1762 /* Called when a statement with a statement label is about to be
1763 accepted. We add the label to the list of the current namespace,
1764 making sure it hasn't been defined previously and referenced
1768 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1772 labelno
= lp
->value
;
1774 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1775 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1776 &lp
->where
, label_locus
);
1779 lp
->where
= *label_locus
;
1783 case ST_LABEL_FORMAT
:
1784 if (lp
->referenced
== ST_LABEL_TARGET
)
1785 gfc_error ("Label %d at %C already referenced as branch target",
1788 lp
->defined
= ST_LABEL_FORMAT
;
1792 case ST_LABEL_TARGET
:
1793 if (lp
->referenced
== ST_LABEL_FORMAT
)
1794 gfc_error ("Label %d at %C already referenced as a format label",
1797 lp
->defined
= ST_LABEL_TARGET
;
1802 lp
->defined
= ST_LABEL_BAD_TARGET
;
1803 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1809 /* Reference a label. Given a label and its type, see if that
1810 reference is consistent with what is known about that label,
1811 updating the unknown state. Returns FAILURE if something goes
1815 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1817 gfc_sl_type label_type
;
1824 labelno
= lp
->value
;
1826 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1827 label_type
= lp
->defined
;
1830 label_type
= lp
->referenced
;
1831 lp
->where
= gfc_current_locus
;
1834 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1836 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1841 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1842 && type
== ST_LABEL_FORMAT
)
1844 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1849 lp
->referenced
= type
;
1857 /************** Symbol table management subroutines ****************/
1859 /* Basic details: Fortran 95 requires a potentially unlimited number
1860 of distinct namespaces when compiling a program unit. This case
1861 occurs during a compilation of internal subprograms because all of
1862 the internal subprograms must be read before we can start
1863 generating code for the host.
1865 Given the tricky nature of the Fortran grammar, we must be able to
1866 undo changes made to a symbol table if the current interpretation
1867 of a statement is found to be incorrect. Whenever a symbol is
1868 looked up, we make a copy of it and link to it. All of these
1869 symbols are kept in a singly linked list so that we can commit or
1870 undo the changes at a later time.
1872 A symtree may point to a symbol node outside of its namespace. In
1873 this case, that symbol has been used as a host associated variable
1874 at some previous time. */
1876 /* Allocate a new namespace structure. Copies the implicit types from
1877 PARENT if PARENT_TYPES is set. */
1880 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
1884 gfc_intrinsic_op in
;
1887 ns
= gfc_getmem (sizeof (gfc_namespace
));
1888 ns
->sym_root
= NULL
;
1889 ns
->uop_root
= NULL
;
1890 ns
->default_access
= ACCESS_UNKNOWN
;
1891 ns
->parent
= parent
;
1893 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1894 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1896 /* Initialize default implicit types. */
1897 for (i
= 'a'; i
<= 'z'; i
++)
1899 ns
->set_flag
[i
- 'a'] = 0;
1900 ts
= &ns
->default_type
[i
- 'a'];
1902 if (parent_types
&& ns
->parent
!= NULL
)
1904 /* Copy parent settings. */
1905 *ts
= ns
->parent
->default_type
[i
- 'a'];
1909 if (gfc_option
.flag_implicit_none
!= 0)
1915 if ('i' <= i
&& i
<= 'n')
1917 ts
->type
= BT_INTEGER
;
1918 ts
->kind
= gfc_default_integer_kind
;
1923 ts
->kind
= gfc_default_real_kind
;
1933 /* Comparison function for symtree nodes. */
1936 compare_symtree (void *_st1
, void *_st2
)
1938 gfc_symtree
*st1
, *st2
;
1940 st1
= (gfc_symtree
*) _st1
;
1941 st2
= (gfc_symtree
*) _st2
;
1943 return strcmp (st1
->name
, st2
->name
);
1947 /* Allocate a new symtree node and associate it with the new symbol. */
1950 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
1954 st
= gfc_getmem (sizeof (gfc_symtree
));
1955 st
->name
= gfc_get_string (name
);
1957 gfc_insert_bbt (root
, st
, compare_symtree
);
1962 /* Delete a symbol from the tree. Does not free the symbol itself! */
1965 delete_symtree (gfc_symtree
**root
, const char *name
)
1967 gfc_symtree st
, *st0
;
1969 st0
= gfc_find_symtree (*root
, name
);
1971 st
.name
= gfc_get_string (name
);
1972 gfc_delete_bbt (root
, &st
, compare_symtree
);
1978 /* Given a root symtree node and a name, try to find the symbol within
1979 the namespace. Returns NULL if the symbol is not found. */
1982 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
1988 c
= strcmp (name
, st
->name
);
1992 st
= (c
< 0) ? st
->left
: st
->right
;
1999 /* Given a name find a user operator node, creating it if it doesn't
2000 exist. These are much simpler than symbols because they can't be
2001 ambiguous with one another. */
2004 gfc_get_uop (const char *name
)
2009 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2013 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2015 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2016 uop
->name
= gfc_get_string (name
);
2017 uop
->access
= ACCESS_UNKNOWN
;
2018 uop
->ns
= gfc_current_ns
;
2024 /* Given a name find the user operator node. Returns NULL if it does
2028 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2033 ns
= gfc_current_ns
;
2035 st
= gfc_find_symtree (ns
->uop_root
, name
);
2036 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2040 /* Remove a gfc_symbol structure and everything it points to. */
2043 gfc_free_symbol (gfc_symbol
*sym
)
2049 gfc_free_array_spec (sym
->as
);
2051 free_components (sym
->components
);
2053 gfc_free_expr (sym
->value
);
2055 gfc_free_namelist (sym
->namelist
);
2057 gfc_free_namespace (sym
->formal_ns
);
2059 if (!sym
->attr
.generic_copy
)
2060 gfc_free_interface (sym
->generic
);
2062 gfc_free_formal_arglist (sym
->formal
);
2068 /* Allocate and initialize a new symbol node. */
2071 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2075 p
= gfc_getmem (sizeof (gfc_symbol
));
2077 gfc_clear_ts (&p
->ts
);
2078 gfc_clear_attr (&p
->attr
);
2081 p
->declared_at
= gfc_current_locus
;
2083 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2084 gfc_internal_error ("new_symbol(): Symbol name too long");
2086 p
->name
= gfc_get_string (name
);
2091 /* Generate an error if a symbol is ambiguous. */
2094 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2097 if (st
->n
.sym
->module
)
2098 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2099 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2101 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2102 "from current program unit", name
, st
->n
.sym
->name
);
2106 /* Search for a symtree starting in the current namespace, resorting to
2107 any parent namespaces if requested by a nonzero parent_flag.
2108 Returns nonzero if the name is ambiguous. */
2111 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2112 gfc_symtree
**result
)
2117 ns
= gfc_current_ns
;
2121 st
= gfc_find_symtree (ns
->sym_root
, name
);
2125 /* Ambiguous generic interfaces are permitted, as long
2126 as the specific interfaces are different. */
2127 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2129 ambiguous_symbol (name
, st
);
2148 /* Same, but returns the symbol instead. */
2151 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2152 gfc_symbol
**result
)
2157 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2162 *result
= st
->n
.sym
;
2168 /* Save symbol with the information necessary to back it out. */
2171 save_symbol_data (gfc_symbol
*sym
)
2174 if (sym
->new || sym
->old_symbol
!= NULL
)
2177 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2178 *(sym
->old_symbol
) = *sym
;
2180 sym
->tlink
= changed_syms
;
2185 /* Given a name, find a symbol, or create it if it does not exist yet
2186 in the current namespace. If the symbol is found we make sure that
2189 The integer return code indicates
2191 1 The symbol name was ambiguous
2192 2 The name meant to be established was already host associated.
2194 So if the return value is nonzero, then an error was issued. */
2197 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2202 /* This doesn't usually happen during resolution. */
2204 ns
= gfc_current_ns
;
2206 /* Try to find the symbol in ns. */
2207 st
= gfc_find_symtree (ns
->sym_root
, name
);
2211 /* If not there, create a new symbol. */
2212 p
= gfc_new_symbol (name
, ns
);
2214 /* Add to the list of tentative symbols. */
2215 p
->old_symbol
= NULL
;
2216 p
->tlink
= changed_syms
;
2221 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2228 /* Make sure the existing symbol is OK. Ambiguous
2229 generic interfaces are permitted, as long as the
2230 specific interfaces are different. */
2231 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2233 ambiguous_symbol (name
, st
);
2239 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2241 /* Symbol is from another namespace. */
2242 gfc_error ("Symbol '%s' at %C has already been host associated",
2249 /* Copy in case this symbol is changed. */
2250 save_symbol_data (p
);
2259 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2264 i
= gfc_get_sym_tree (name
, ns
, &st
);
2269 *result
= st
->n
.sym
;
2276 /* Subroutine that searches for a symbol, creating it if it doesn't
2277 exist, but tries to host-associate the symbol if possible. */
2280 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2285 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2288 save_symbol_data (st
->n
.sym
);
2293 if (gfc_current_ns
->parent
!= NULL
)
2295 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2306 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2311 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2316 i
= gfc_get_ha_sym_tree (name
, &st
);
2319 *result
= st
->n
.sym
;
2326 /* Return true if both symbols could refer to the same data object. Does
2327 not take account of aliasing due to equivalence statements. */
2330 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2332 /* Aliasing isn't possible if the symbols have different base types. */
2333 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2336 /* Pointers can point to other pointers, target objects and allocatable
2337 objects. Two allocatable objects cannot share the same storage. */
2338 if (lsym
->attr
.pointer
2339 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2341 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2343 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2350 /* Undoes all the changes made to symbols in the current statement.
2351 This subroutine is made simpler due to the fact that attributes are
2352 never removed once added. */
2355 gfc_undo_symbols (void)
2357 gfc_symbol
*p
, *q
, *old
;
2359 for (p
= changed_syms
; p
; p
= q
)
2365 /* Symbol was new. */
2366 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2370 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2372 gfc_free_symbol (p
);
2376 /* Restore previous state of symbol. Just copy simple stuff. */
2378 old
= p
->old_symbol
;
2380 p
->ts
.type
= old
->ts
.type
;
2381 p
->ts
.kind
= old
->ts
.kind
;
2383 p
->attr
= old
->attr
;
2385 if (p
->value
!= old
->value
)
2387 gfc_free_expr (old
->value
);
2391 if (p
->as
!= old
->as
)
2394 gfc_free_array_spec (p
->as
);
2398 p
->generic
= old
->generic
;
2399 p
->component_access
= old
->component_access
;
2401 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2403 gfc_free_namelist (p
->namelist
);
2408 if (p
->namelist_tail
!= old
->namelist_tail
)
2410 gfc_free_namelist (old
->namelist_tail
);
2411 old
->namelist_tail
->next
= NULL
;
2415 p
->namelist_tail
= old
->namelist_tail
;
2417 if (p
->formal
!= old
->formal
)
2419 gfc_free_formal_arglist (p
->formal
);
2420 p
->formal
= old
->formal
;
2423 gfc_free (p
->old_symbol
);
2424 p
->old_symbol
= NULL
;
2428 changed_syms
= NULL
;
2432 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2433 components of old_symbol that might need deallocation are the "allocatables"
2434 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2435 namelist_tail. In case these differ between old_symbol and sym, it's just
2436 because sym->namelist has gotten a few more items. */
2439 free_old_symbol (gfc_symbol
*sym
)
2442 if (sym
->old_symbol
== NULL
)
2445 if (sym
->old_symbol
->as
!= sym
->as
)
2446 gfc_free_array_spec (sym
->old_symbol
->as
);
2448 if (sym
->old_symbol
->value
!= sym
->value
)
2449 gfc_free_expr (sym
->old_symbol
->value
);
2451 if (sym
->old_symbol
->formal
!= sym
->formal
)
2452 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2454 gfc_free (sym
->old_symbol
);
2455 sym
->old_symbol
= NULL
;
2459 /* Makes the changes made in the current statement permanent-- gets
2460 rid of undo information. */
2463 gfc_commit_symbols (void)
2467 for (p
= changed_syms
; p
; p
= q
)
2473 free_old_symbol (p
);
2475 changed_syms
= NULL
;
2479 /* Makes the changes made in one symbol permanent -- gets rid of undo
2483 gfc_commit_symbol (gfc_symbol
*sym
)
2487 if (changed_syms
== sym
)
2488 changed_syms
= sym
->tlink
;
2491 for (p
= changed_syms
; p
; p
= p
->tlink
)
2492 if (p
->tlink
== sym
)
2494 p
->tlink
= sym
->tlink
;
2503 free_old_symbol (sym
);
2507 /* Recursive function that deletes an entire tree and all the common
2508 head structures it points to. */
2511 free_common_tree (gfc_symtree
* common_tree
)
2513 if (common_tree
== NULL
)
2516 free_common_tree (common_tree
->left
);
2517 free_common_tree (common_tree
->right
);
2519 gfc_free (common_tree
);
2523 /* Recursive function that deletes an entire tree and all the user
2524 operator nodes that it contains. */
2527 free_uop_tree (gfc_symtree
*uop_tree
)
2530 if (uop_tree
== NULL
)
2533 free_uop_tree (uop_tree
->left
);
2534 free_uop_tree (uop_tree
->right
);
2536 gfc_free_interface (uop_tree
->n
.uop
->operator);
2538 gfc_free (uop_tree
->n
.uop
);
2539 gfc_free (uop_tree
);
2543 /* Recursive function that deletes an entire tree and all the symbols
2544 that it contains. */
2547 free_sym_tree (gfc_symtree
*sym_tree
)
2552 if (sym_tree
== NULL
)
2555 free_sym_tree (sym_tree
->left
);
2556 free_sym_tree (sym_tree
->right
);
2558 sym
= sym_tree
->n
.sym
;
2562 gfc_internal_error ("free_sym_tree(): Negative refs");
2564 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2566 /* As formal_ns contains a reference to sym, delete formal_ns just
2567 before the deletion of sym. */
2568 ns
= sym
->formal_ns
;
2569 sym
->formal_ns
= NULL
;
2570 gfc_free_namespace (ns
);
2572 else if (sym
->refs
== 0)
2574 /* Go ahead and delete the symbol. */
2575 gfc_free_symbol (sym
);
2578 gfc_free (sym_tree
);
2582 /* Free the derived type list. */
2585 gfc_free_dt_list (void)
2587 gfc_dt_list
*dt
, *n
;
2589 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2595 gfc_derived_types
= NULL
;
2599 /* Free the gfc_equiv_info's. */
2602 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2606 gfc_free_equiv_infos (s
->next
);
2611 /* Free the gfc_equiv_lists. */
2614 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2618 gfc_free_equiv_lists (l
->next
);
2619 gfc_free_equiv_infos (l
->equiv
);
2624 /* Free a namespace structure and everything below it. Interface
2625 lists associated with intrinsic operators are not freed. These are
2626 taken care of when a specific name is freed. */
2629 gfc_free_namespace (gfc_namespace
*ns
)
2631 gfc_charlen
*cl
, *cl2
;
2632 gfc_namespace
*p
, *q
;
2641 gcc_assert (ns
->refs
== 0);
2643 gfc_free_statements (ns
->code
);
2645 free_sym_tree (ns
->sym_root
);
2646 free_uop_tree (ns
->uop_root
);
2647 free_common_tree (ns
->common_root
);
2649 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2652 gfc_free_expr (cl
->length
);
2656 free_st_labels (ns
->st_labels
);
2658 gfc_free_equiv (ns
->equiv
);
2659 gfc_free_equiv_lists (ns
->equiv_lists
);
2661 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2662 gfc_free_interface (ns
->operator[i
]);
2664 gfc_free_data (ns
->data
);
2668 /* Recursively free any contained namespaces. */
2673 gfc_free_namespace (q
);
2679 gfc_symbol_init_2 (void)
2682 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2687 gfc_symbol_done_2 (void)
2690 gfc_free_namespace (gfc_current_ns
);
2691 gfc_current_ns
= NULL
;
2692 gfc_free_dt_list ();
2696 /* Clear mark bits from symbol nodes associated with a symtree node. */
2699 clear_sym_mark (gfc_symtree
*st
)
2702 st
->n
.sym
->mark
= 0;
2706 /* Recursively traverse the symtree nodes. */
2709 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2715 gfc_traverse_symtree (st
->left
, func
);
2716 gfc_traverse_symtree (st
->right
, func
);
2721 /* Recursive namespace traversal function. */
2724 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2730 if (st
->n
.sym
->mark
== 0)
2731 (*func
) (st
->n
.sym
);
2732 st
->n
.sym
->mark
= 1;
2734 traverse_ns (st
->left
, func
);
2735 traverse_ns (st
->right
, func
);
2739 /* Call a given function for all symbols in the namespace. We take
2740 care that each gfc_symbol node is called exactly once. */
2743 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2746 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2748 traverse_ns (ns
->sym_root
, func
);
2752 /* Return TRUE if the symbol is an automatic variable. */
2755 gfc_is_var_automatic (gfc_symbol
*sym
)
2757 /* Pointer and allocatable variables are never automatic. */
2758 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2760 /* Check for arrays with non-constant size. */
2761 if (sym
->attr
.dimension
&& sym
->as
2762 && !gfc_is_compile_time_shape (sym
->as
))
2764 /* Check for non-constant length character variables. */
2765 if (sym
->ts
.type
== BT_CHARACTER
2767 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2772 /* Given a symbol, mark it as SAVEd if it is allowed. */
2775 save_symbol (gfc_symbol
*sym
)
2778 if (sym
->attr
.use_assoc
)
2781 if (sym
->attr
.in_common
2783 || sym
->attr
.flavor
!= FL_VARIABLE
)
2785 /* Automatic objects are not saved. */
2786 if (gfc_is_var_automatic (sym
))
2788 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2792 /* Mark those symbols which can be SAVEd as such. */
2795 gfc_save_all (gfc_namespace
*ns
)
2798 gfc_traverse_ns (ns
, save_symbol
);
2803 /* Make sure that no changes to symbols are pending. */
2806 gfc_symbol_state(void) {
2808 if (changed_syms
!= NULL
)
2809 gfc_internal_error("Symbol changes still pending!");
2814 /************** Global symbol handling ************/
2817 /* Search a tree for the global symbol. */
2820 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2829 c
= strcmp (name
, symbol
->name
);
2833 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2840 /* Compare two global symbols. Used for managing the BB tree. */
2843 gsym_compare (void *_s1
, void *_s2
)
2845 gfc_gsymbol
*s1
, *s2
;
2847 s1
= (gfc_gsymbol
*) _s1
;
2848 s2
= (gfc_gsymbol
*) _s2
;
2849 return strcmp (s1
->name
, s2
->name
);
2853 /* Get a global symbol, creating it if it doesn't exist. */
2856 gfc_get_gsymbol (const char *name
)
2860 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2864 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2865 s
->type
= GSYM_UNKNOWN
;
2866 s
->name
= gfc_get_string (name
);
2868 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);