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
)
274 proc
->ts
= proc
->result
->ts
;
278 gfc_error ("unable to implicitly type the function result "
279 "'%s' at %L", proc
->result
->name
,
280 &proc
->result
->declared_at
);
281 proc
->result
->attr
.untyped
= 1;
287 /******************** Symbol attribute stuff *********************/
289 /* This is a generic conflict-checker. We do this to avoid having a
290 single conflict in two places. */
292 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
293 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
294 #define conf_std(a, b, std) if (attr->a && attr->b)\
303 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
305 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
306 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
307 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
308 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
309 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
310 *private = "PRIVATE", *recursive
= "RECURSIVE",
311 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
312 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
313 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
314 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
315 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
316 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
317 *volatile_
= "VOLATILE", *protected = "PROTECTED";
318 static const char *threadprivate
= "THREADPRIVATE";
324 where
= &gfc_current_locus
;
326 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
330 standard
= GFC_STD_F2003
;
334 /* Check for attributes not allowed in a BLOCK DATA. */
335 if (gfc_current_state () == COMP_BLOCK_DATA
)
339 if (attr
->in_namelist
)
341 if (attr
->allocatable
)
347 if (attr
->access
== ACCESS_PRIVATE
)
349 if (attr
->access
== ACCESS_PUBLIC
)
351 if (attr
->intent
!= INTENT_UNKNOWN
)
357 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
364 conf (dummy
, intrinsic
);
366 conf (dummy
, threadprivate
);
367 conf (pointer
, target
);
368 conf (pointer
, external
);
369 conf (pointer
, intrinsic
);
370 conf (pointer
, elemental
);
371 conf (allocatable
, elemental
);
373 conf (target
, external
);
374 conf (target
, intrinsic
);
375 conf (external
, dimension
); /* See Fortran 95's R504. */
377 conf (external
, intrinsic
);
379 if (attr
->if_source
|| attr
->contained
)
381 conf (external
, subroutine
);
382 conf (external
, function
);
385 conf (allocatable
, pointer
);
386 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
387 conf_std (allocatable
, function
, GFC_STD_F2003
);
388 conf_std (allocatable
, result
, GFC_STD_F2003
);
389 conf (elemental
, recursive
);
391 conf (in_common
, dummy
);
392 conf (in_common
, allocatable
);
393 conf (in_common
, result
);
394 conf (in_common
, save
);
397 conf (dummy
, result
);
399 conf (in_equivalence
, use_assoc
);
400 conf (in_equivalence
, dummy
);
401 conf (in_equivalence
, target
);
402 conf (in_equivalence
, pointer
);
403 conf (in_equivalence
, function
);
404 conf (in_equivalence
, result
);
405 conf (in_equivalence
, entry
);
406 conf (in_equivalence
, allocatable
);
407 conf (in_equivalence
, threadprivate
);
409 conf (in_namelist
, pointer
);
410 conf (in_namelist
, allocatable
);
412 conf (entry
, result
);
414 conf (function
, subroutine
);
416 /* Cray pointer/pointee conflicts. */
417 conf (cray_pointer
, cray_pointee
);
418 conf (cray_pointer
, dimension
);
419 conf (cray_pointer
, pointer
);
420 conf (cray_pointer
, target
);
421 conf (cray_pointer
, allocatable
);
422 conf (cray_pointer
, external
);
423 conf (cray_pointer
, intrinsic
);
424 conf (cray_pointer
, in_namelist
);
425 conf (cray_pointer
, function
);
426 conf (cray_pointer
, subroutine
);
427 conf (cray_pointer
, entry
);
429 conf (cray_pointee
, allocatable
);
430 conf (cray_pointee
, intent
);
431 conf (cray_pointee
, optional
);
432 conf (cray_pointee
, dummy
);
433 conf (cray_pointee
, target
);
434 conf (cray_pointee
, intrinsic
);
435 conf (cray_pointee
, pointer
);
436 conf (cray_pointee
, entry
);
437 conf (cray_pointee
, in_common
);
438 conf (cray_pointee
, in_equivalence
);
439 conf (cray_pointee
, threadprivate
);
442 conf (data
, function
);
444 conf (data
, allocatable
);
445 conf (data
, use_assoc
);
447 conf (protected, intrinsic
)
448 conf (protected, external
)
449 conf (protected, in_common
)
451 conf (value
, pointer
)
452 conf (value
, allocatable
)
453 conf (value
, subroutine
)
454 conf (value
, function
)
455 conf (value
, volatile_
)
456 conf (value
, dimension
)
457 conf (value
, external
)
459 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
462 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
466 conf (volatile_
, intrinsic
)
467 conf (volatile_
, external
)
469 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
476 a1
= gfc_code2string (flavors
, attr
->flavor
);
478 if (attr
->in_namelist
479 && attr
->flavor
!= FL_VARIABLE
480 && attr
->flavor
!= FL_UNKNOWN
)
487 switch (attr
->flavor
)
508 conf2 (threadprivate
);
519 if (attr
->subroutine
)
528 conf2(threadprivate
);
533 case PROC_ST_FUNCTION
:
546 conf2 (threadprivate
);
567 conf2 (threadprivate
);
569 if (attr
->intent
!= INTENT_UNKNOWN
)
592 conf2 (threadprivate
);
603 gfc_error ("%s attribute conflicts with %s attribute at %L",
606 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
607 a1
, a2
, name
, where
);
614 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
615 "with %s attribute at %L", a1
, a2
,
620 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
621 "with %s attribute in '%s' at %L",
622 a1
, a2
, name
, where
);
631 /* Mark a symbol as referenced. */
634 gfc_set_sym_referenced (gfc_symbol
* sym
)
636 if (sym
->attr
.referenced
)
639 sym
->attr
.referenced
= 1;
641 /* Remember which order dummy variables are accessed in. */
643 sym
->dummy_order
= next_dummy_order
++;
647 /* Common subroutine called by attribute changing subroutines in order
648 to prevent them from changing a symbol that has been
649 use-associated. Returns zero if it is OK to change the symbol,
653 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
656 if (attr
->use_assoc
== 0)
660 where
= &gfc_current_locus
;
663 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
666 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
673 /* Generate an error because of a duplicate attribute. */
676 duplicate_attr (const char *attr
, locus
* where
)
680 where
= &gfc_current_locus
;
682 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
685 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
688 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
690 if (check_used (attr
, NULL
, where
))
693 return check_conflict (attr
, NULL
, where
);
697 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
700 if (check_used (attr
, NULL
, where
))
703 if (attr
->allocatable
)
705 duplicate_attr ("ALLOCATABLE", where
);
709 attr
->allocatable
= 1;
710 return check_conflict (attr
, NULL
, where
);
715 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
718 if (check_used (attr
, name
, where
))
723 duplicate_attr ("DIMENSION", where
);
728 return check_conflict (attr
, name
, where
);
733 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
736 if (check_used (attr
, NULL
, where
))
741 duplicate_attr ("EXTERNAL", where
);
747 return check_conflict (attr
, NULL
, where
);
752 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
755 if (check_used (attr
, NULL
, where
))
760 duplicate_attr ("INTRINSIC", where
);
766 return check_conflict (attr
, NULL
, where
);
771 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
774 if (check_used (attr
, NULL
, where
))
779 duplicate_attr ("OPTIONAL", where
);
784 return check_conflict (attr
, NULL
, where
);
789 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
792 if (check_used (attr
, NULL
, where
))
796 return check_conflict (attr
, NULL
, where
);
801 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
804 if (check_used (attr
, NULL
, where
))
807 attr
->cray_pointer
= 1;
808 return check_conflict (attr
, NULL
, where
);
813 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
816 if (check_used (attr
, NULL
, where
))
819 if (attr
->cray_pointee
)
821 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
822 " statements", where
);
826 attr
->cray_pointee
= 1;
827 return check_conflict (attr
, NULL
, where
);
831 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
833 if (check_used (attr
, name
, where
))
838 if (gfc_notify_std (GFC_STD_LEGACY
,
839 "Duplicate PROTECTED attribute specified at %L",
846 return check_conflict (attr
, name
, where
);
850 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
853 if (check_used (attr
, name
, where
))
857 return check_conflict (attr
, name
, where
);
862 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
865 if (check_used (attr
, name
, where
))
871 ("SAVE attribute at %L cannot be specified in a PURE procedure",
878 if (gfc_notify_std (GFC_STD_LEGACY
,
879 "Duplicate SAVE attribute specified at %L",
886 return check_conflict (attr
, name
, where
);
890 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
893 if (check_used (attr
, name
, where
))
898 if (gfc_notify_std (GFC_STD_LEGACY
,
899 "Duplicate VALUE attribute specified at %L",
906 return check_conflict (attr
, name
, where
);
910 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
912 /* No check_used needed as 11.2.1 of the F2003 standard allows
913 that the local identifier made accessible by a use statement can be
914 given a VOLATILE attribute. */
916 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
917 if (gfc_notify_std (GFC_STD_LEGACY
,
918 "Duplicate VOLATILE attribute specified at %L", where
)
923 attr
->volatile_ns
= gfc_current_ns
;
924 return check_conflict (attr
, name
, where
);
929 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
931 if (check_used (attr
, name
, where
))
934 if (attr
->threadprivate
)
936 duplicate_attr ("THREADPRIVATE", where
);
940 attr
->threadprivate
= 1;
941 return check_conflict (attr
, name
, where
);
946 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
949 if (check_used (attr
, NULL
, where
))
954 duplicate_attr ("TARGET", where
);
959 return check_conflict (attr
, NULL
, where
);
964 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
967 if (check_used (attr
, name
, where
))
970 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
972 return check_conflict (attr
, name
, where
);
977 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
980 if (check_used (attr
, name
, where
))
983 /* Duplicate attribute already checked for. */
985 if (check_conflict (attr
, name
, where
) == FAILURE
)
988 if (attr
->flavor
== FL_VARIABLE
)
991 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
995 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
998 /* Duplicate attribute already checked for. */
999 attr
->in_equivalence
= 1;
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_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1014 if (check_used (attr
, name
, where
))
1018 return check_conflict (attr
, name
, where
);
1023 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
1027 attr
->in_namelist
= 1;
1028 return check_conflict (attr
, name
, where
);
1033 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
1036 if (check_used (attr
, name
, where
))
1040 return check_conflict (attr
, name
, where
);
1045 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1048 if (check_used (attr
, NULL
, where
))
1051 attr
->elemental
= 1;
1052 return check_conflict (attr
, NULL
, where
);
1057 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1060 if (check_used (attr
, NULL
, where
))
1064 return check_conflict (attr
, NULL
, where
);
1069 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1072 if (check_used (attr
, NULL
, where
))
1075 attr
->recursive
= 1;
1076 return check_conflict (attr
, NULL
, where
);
1081 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1084 if (check_used (attr
, name
, where
))
1089 duplicate_attr ("ENTRY", where
);
1094 return check_conflict (attr
, name
, where
);
1099 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1102 if (attr
->flavor
!= FL_PROCEDURE
1103 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1107 return check_conflict (attr
, name
, where
);
1112 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1115 if (attr
->flavor
!= FL_PROCEDURE
1116 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1119 attr
->subroutine
= 1;
1120 return check_conflict (attr
, name
, where
);
1125 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1128 if (attr
->flavor
!= FL_PROCEDURE
1129 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1133 return check_conflict (attr
, name
, where
);
1137 /* Flavors are special because some flavors are not what Fortran
1138 considers attributes and can be reaffirmed multiple times. */
1141 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1145 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1146 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1147 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1150 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1153 if (attr
->flavor
!= FL_UNKNOWN
)
1156 where
= &gfc_current_locus
;
1158 gfc_error ("%s attribute conflicts with %s attribute at %L",
1159 gfc_code2string (flavors
, attr
->flavor
),
1160 gfc_code2string (flavors
, f
), where
);
1167 return check_conflict (attr
, name
, where
);
1172 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1173 const char *name
, locus
* where
)
1176 if (check_used (attr
, name
, where
))
1179 if (attr
->flavor
!= FL_PROCEDURE
1180 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1184 where
= &gfc_current_locus
;
1186 if (attr
->proc
!= PROC_UNKNOWN
)
1188 gfc_error ("%s procedure at %L is already declared as %s procedure",
1189 gfc_code2string (procedures
, t
), where
,
1190 gfc_code2string (procedures
, attr
->proc
));
1197 /* Statement functions are always scalar and functions. */
1198 if (t
== PROC_ST_FUNCTION
1199 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1200 || attr
->dimension
))
1203 return check_conflict (attr
, name
, where
);
1208 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1211 if (check_used (attr
, NULL
, where
))
1214 if (attr
->intent
== INTENT_UNKNOWN
)
1216 attr
->intent
= intent
;
1217 return check_conflict (attr
, NULL
, where
);
1221 where
= &gfc_current_locus
;
1223 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1224 gfc_intent_string (attr
->intent
),
1225 gfc_intent_string (intent
), where
);
1231 /* No checks for use-association in public and private statements. */
1234 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1235 const char *name
, locus
* where
)
1238 if (attr
->access
== ACCESS_UNKNOWN
)
1240 attr
->access
= access
;
1241 return check_conflict (attr
, name
, where
);
1245 where
= &gfc_current_locus
;
1246 gfc_error ("ACCESS specification at %L was already specified", where
);
1253 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1254 gfc_formal_arglist
* formal
, locus
* where
)
1257 if (check_used (&sym
->attr
, sym
->name
, where
))
1261 where
= &gfc_current_locus
;
1263 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1264 && sym
->attr
.if_source
!= IFSRC_DECL
)
1266 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1271 sym
->formal
= formal
;
1272 sym
->attr
.if_source
= source
;
1278 /* Add a type to a symbol. */
1281 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1286 where
= &gfc_current_locus
;
1288 if (sym
->ts
.type
!= BT_UNKNOWN
)
1290 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1291 if (!(sym
->ts
.type
== ts
->type
1292 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1293 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1296 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1299 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1300 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1304 flavor
= sym
->attr
.flavor
;
1306 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1307 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1308 && sym
->attr
.subroutine
)
1309 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1311 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1320 /* Clears all attributes. */
1323 gfc_clear_attr (symbol_attribute
* attr
)
1325 memset (attr
, 0, sizeof(symbol_attribute
));
1329 /* Check for missing attributes in the new symbol. Currently does
1330 nothing, but it's not clear that it is unnecessary yet. */
1333 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1334 locus
* where ATTRIBUTE_UNUSED
)
1341 /* Copy an attribute to a symbol attribute, bit by bit. Some
1342 attributes have a lot of side-effects but cannot be present given
1343 where we are called from, so we ignore some bits. */
1346 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1349 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1352 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1354 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1356 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1358 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1360 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1362 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1364 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1366 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1368 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1370 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1372 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1377 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1380 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1383 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1385 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1387 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1390 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1392 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1394 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1396 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1399 if (src
->flavor
!= FL_UNKNOWN
1400 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1403 if (src
->intent
!= INTENT_UNKNOWN
1404 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1407 if (src
->access
!= ACCESS_UNKNOWN
1408 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1411 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1414 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1416 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1419 /* The subroutines that set these bits also cause flavors to be set,
1420 and that has already happened in the original, so don't let it
1425 dest
->intrinsic
= 1;
1434 /************** Component name management ************/
1436 /* Component names of a derived type form their own little namespaces
1437 that are separate from all other spaces. The space is composed of
1438 a singly linked list of gfc_component structures whose head is
1439 located in the parent symbol. */
1442 /* Add a component name to a symbol. The call fails if the name is
1443 already present. On success, the component pointer is modified to
1444 point to the additional component structure. */
1447 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1449 gfc_component
*p
, *tail
;
1453 for (p
= sym
->components
; p
; p
= p
->next
)
1455 if (strcmp (p
->name
, name
) == 0)
1457 gfc_error ("Component '%s' at %C already declared at %L",
1465 /* Allocate a new component. */
1466 p
= gfc_get_component ();
1469 sym
->components
= p
;
1473 p
->name
= gfc_get_string (name
);
1474 p
->loc
= gfc_current_locus
;
1481 /* Recursive function to switch derived types of all symbol in a
1485 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1493 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1494 sym
->ts
.derived
= to
;
1496 switch_types (st
->left
, from
, to
);
1497 switch_types (st
->right
, from
, to
);
1501 /* This subroutine is called when a derived type is used in order to
1502 make the final determination about which version to use. The
1503 standard requires that a type be defined before it is 'used', but
1504 such types can appear in IMPLICIT statements before the actual
1505 definition. 'Using' in this context means declaring a variable to
1506 be that type or using the type constructor.
1508 If a type is used and the components haven't been defined, then we
1509 have to have a derived type in a parent unit. We find the node in
1510 the other namespace and point the symtree node in this namespace to
1511 that node. Further reference to this name point to the correct
1512 node. If we can't find the node in a parent namespace, then we have
1515 This subroutine takes a pointer to a symbol node and returns a
1516 pointer to the translated node or NULL for an error. Usually there
1517 is no translation and we return the node we were passed. */
1520 gfc_use_derived (gfc_symbol
* sym
)
1527 if (sym
->components
!= NULL
)
1528 return sym
; /* Already defined. */
1530 if (sym
->ns
->parent
== NULL
)
1533 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1535 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1539 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1542 /* Get rid of symbol sym, translating all references to s. */
1543 for (i
= 0; i
< GFC_LETTERS
; i
++)
1545 t
= &sym
->ns
->default_type
[i
];
1546 if (t
->derived
== sym
)
1550 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1555 /* Unlink from list of modified symbols. */
1556 gfc_commit_symbol (sym
);
1558 switch_types (sym
->ns
->sym_root
, sym
, s
);
1560 /* TODO: Also have to replace sym -> s in other lists like
1561 namelists, common lists and interface lists. */
1562 gfc_free_symbol (sym
);
1567 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1573 /* Given a derived type node and a component name, try to locate the
1574 component structure. Returns the NULL pointer if the component is
1575 not found or the components are private. */
1578 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1585 sym
= gfc_use_derived (sym
);
1590 for (p
= sym
->components
; p
; p
= p
->next
)
1591 if (strcmp (p
->name
, name
) == 0)
1595 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1599 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1601 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1611 /* Given a symbol, free all of the component structures and everything
1615 free_components (gfc_component
* p
)
1623 gfc_free_array_spec (p
->as
);
1624 gfc_free_expr (p
->initializer
);
1631 /* Set component attributes from a standard symbol attribute
1635 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1638 c
->dimension
= attr
->dimension
;
1639 c
->pointer
= attr
->pointer
;
1640 c
->allocatable
= attr
->allocatable
;
1644 /* Get a standard symbol attribute structure given the component
1648 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1651 gfc_clear_attr (attr
);
1652 attr
->dimension
= c
->dimension
;
1653 attr
->pointer
= c
->pointer
;
1654 attr
->allocatable
= c
->allocatable
;
1658 /******************** Statement label management ********************/
1660 /* Comparison function for statement labels, used for managing the
1664 compare_st_labels (void * a1
, void * b1
)
1666 int a
= ((gfc_st_label
*)a1
)->value
;
1667 int b
= ((gfc_st_label
*)b1
)->value
;
1673 /* Free a single gfc_st_label structure, making sure the tree is not
1674 messed up. This function is called only when some parse error
1678 gfc_free_st_label (gfc_st_label
* label
)
1683 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1685 if (label
->format
!= NULL
)
1686 gfc_free_expr (label
->format
);
1691 /* Free a whole tree of gfc_st_label structures. */
1694 free_st_labels (gfc_st_label
* label
)
1699 free_st_labels (label
->left
);
1700 free_st_labels (label
->right
);
1702 if (label
->format
!= NULL
)
1703 gfc_free_expr (label
->format
);
1708 /* Given a label number, search for and return a pointer to the label
1709 structure, creating it if it does not exist. */
1712 gfc_get_st_label (int labelno
)
1716 /* First see if the label is already in this namespace. */
1717 lp
= gfc_current_ns
->st_labels
;
1720 if (lp
->value
== labelno
)
1723 if (lp
->value
< labelno
)
1729 lp
= gfc_getmem (sizeof (gfc_st_label
));
1731 lp
->value
= labelno
;
1732 lp
->defined
= ST_LABEL_UNKNOWN
;
1733 lp
->referenced
= ST_LABEL_UNKNOWN
;
1735 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1741 /* Called when a statement with a statement label is about to be
1742 accepted. We add the label to the list of the current namespace,
1743 making sure it hasn't been defined previously and referenced
1747 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1751 labelno
= lp
->value
;
1753 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1754 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1755 &lp
->where
, label_locus
);
1758 lp
->where
= *label_locus
;
1762 case ST_LABEL_FORMAT
:
1763 if (lp
->referenced
== ST_LABEL_TARGET
)
1764 gfc_error ("Label %d at %C already referenced as branch target",
1767 lp
->defined
= ST_LABEL_FORMAT
;
1771 case ST_LABEL_TARGET
:
1772 if (lp
->referenced
== ST_LABEL_FORMAT
)
1773 gfc_error ("Label %d at %C already referenced as a format label",
1776 lp
->defined
= ST_LABEL_TARGET
;
1781 lp
->defined
= ST_LABEL_BAD_TARGET
;
1782 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1788 /* Reference a label. Given a label and its type, see if that
1789 reference is consistent with what is known about that label,
1790 updating the unknown state. Returns FAILURE if something goes
1794 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1796 gfc_sl_type label_type
;
1803 labelno
= lp
->value
;
1805 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1806 label_type
= lp
->defined
;
1809 label_type
= lp
->referenced
;
1810 lp
->where
= gfc_current_locus
;
1813 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1815 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1820 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1821 && type
== ST_LABEL_FORMAT
)
1823 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1828 lp
->referenced
= type
;
1836 /************** Symbol table management subroutines ****************/
1838 /* Basic details: Fortran 95 requires a potentially unlimited number
1839 of distinct namespaces when compiling a program unit. This case
1840 occurs during a compilation of internal subprograms because all of
1841 the internal subprograms must be read before we can start
1842 generating code for the host.
1844 Given the tricky nature of the Fortran grammar, we must be able to
1845 undo changes made to a symbol table if the current interpretation
1846 of a statement is found to be incorrect. Whenever a symbol is
1847 looked up, we make a copy of it and link to it. All of these
1848 symbols are kept in a singly linked list so that we can commit or
1849 undo the changes at a later time.
1851 A symtree may point to a symbol node outside of its namespace. In
1852 this case, that symbol has been used as a host associated variable
1853 at some previous time. */
1855 /* Allocate a new namespace structure. Copies the implicit types from
1856 PARENT if PARENT_TYPES is set. */
1859 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1863 gfc_intrinsic_op in
;
1866 ns
= gfc_getmem (sizeof (gfc_namespace
));
1867 ns
->sym_root
= NULL
;
1868 ns
->uop_root
= NULL
;
1869 ns
->default_access
= ACCESS_UNKNOWN
;
1870 ns
->parent
= parent
;
1872 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1873 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1875 /* Initialize default implicit types. */
1876 for (i
= 'a'; i
<= 'z'; i
++)
1878 ns
->set_flag
[i
- 'a'] = 0;
1879 ts
= &ns
->default_type
[i
- 'a'];
1881 if (parent_types
&& ns
->parent
!= NULL
)
1883 /* Copy parent settings */
1884 *ts
= ns
->parent
->default_type
[i
- 'a'];
1888 if (gfc_option
.flag_implicit_none
!= 0)
1894 if ('i' <= i
&& i
<= 'n')
1896 ts
->type
= BT_INTEGER
;
1897 ts
->kind
= gfc_default_integer_kind
;
1902 ts
->kind
= gfc_default_real_kind
;
1912 /* Comparison function for symtree nodes. */
1915 compare_symtree (void * _st1
, void * _st2
)
1917 gfc_symtree
*st1
, *st2
;
1919 st1
= (gfc_symtree
*) _st1
;
1920 st2
= (gfc_symtree
*) _st2
;
1922 return strcmp (st1
->name
, st2
->name
);
1926 /* Allocate a new symtree node and associate it with the new symbol. */
1929 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1933 st
= gfc_getmem (sizeof (gfc_symtree
));
1934 st
->name
= gfc_get_string (name
);
1936 gfc_insert_bbt (root
, st
, compare_symtree
);
1941 /* Delete a symbol from the tree. Does not free the symbol itself! */
1944 delete_symtree (gfc_symtree
** root
, const char *name
)
1946 gfc_symtree st
, *st0
;
1948 st0
= gfc_find_symtree (*root
, name
);
1950 st
.name
= gfc_get_string (name
);
1951 gfc_delete_bbt (root
, &st
, compare_symtree
);
1957 /* Given a root symtree node and a name, try to find the symbol within
1958 the namespace. Returns NULL if the symbol is not found. */
1961 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1967 c
= strcmp (name
, st
->name
);
1971 st
= (c
< 0) ? st
->left
: st
->right
;
1978 /* Given a name find a user operator node, creating it if it doesn't
1979 exist. These are much simpler than symbols because they can't be
1980 ambiguous with one another. */
1983 gfc_get_uop (const char *name
)
1988 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1992 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1994 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1995 uop
->name
= gfc_get_string (name
);
1996 uop
->access
= ACCESS_UNKNOWN
;
1997 uop
->ns
= gfc_current_ns
;
2003 /* Given a name find the user operator node. Returns NULL if it does
2007 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
2012 ns
= gfc_current_ns
;
2014 st
= gfc_find_symtree (ns
->uop_root
, name
);
2015 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2019 /* Remove a gfc_symbol structure and everything it points to. */
2022 gfc_free_symbol (gfc_symbol
* sym
)
2028 gfc_free_array_spec (sym
->as
);
2030 free_components (sym
->components
);
2032 gfc_free_expr (sym
->value
);
2034 gfc_free_namelist (sym
->namelist
);
2036 gfc_free_namespace (sym
->formal_ns
);
2038 if (!sym
->attr
.generic_copy
)
2039 gfc_free_interface (sym
->generic
);
2041 gfc_free_formal_arglist (sym
->formal
);
2047 /* Allocate and initialize a new symbol node. */
2050 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2054 p
= gfc_getmem (sizeof (gfc_symbol
));
2056 gfc_clear_ts (&p
->ts
);
2057 gfc_clear_attr (&p
->attr
);
2060 p
->declared_at
= gfc_current_locus
;
2062 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2063 gfc_internal_error ("new_symbol(): Symbol name too long");
2065 p
->name
= gfc_get_string (name
);
2070 /* Generate an error if a symbol is ambiguous. */
2073 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2076 if (st
->n
.sym
->module
)
2077 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2078 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2080 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2081 "from current program unit", name
, st
->n
.sym
->name
);
2085 /* Search for a symtree starting in the current namespace, resorting to
2086 any parent namespaces if requested by a nonzero parent_flag.
2087 Returns nonzero if the name is ambiguous. */
2090 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2091 gfc_symtree
** result
)
2096 ns
= gfc_current_ns
;
2100 st
= gfc_find_symtree (ns
->sym_root
, name
);
2104 /* Ambiguous generic interfaces are permitted, as long
2105 as the specific interfaces are different. */
2106 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2108 ambiguous_symbol (name
, st
);
2127 /* Same, but returns the symbol instead. */
2130 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2131 gfc_symbol
** result
)
2136 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2141 *result
= st
->n
.sym
;
2147 /* Save symbol with the information necessary to back it out. */
2150 save_symbol_data (gfc_symbol
* sym
)
2153 if (sym
->new || sym
->old_symbol
!= NULL
)
2156 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2157 *(sym
->old_symbol
) = *sym
;
2159 sym
->tlink
= changed_syms
;
2164 /* Given a name, find a symbol, or create it if it does not exist yet
2165 in the current namespace. If the symbol is found we make sure that
2168 The integer return code indicates
2170 1 The symbol name was ambiguous
2171 2 The name meant to be established was already host associated.
2173 So if the return value is nonzero, then an error was issued. */
2176 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2181 /* This doesn't usually happen during resolution. */
2183 ns
= gfc_current_ns
;
2185 /* Try to find the symbol in ns. */
2186 st
= gfc_find_symtree (ns
->sym_root
, name
);
2190 /* If not there, create a new symbol. */
2191 p
= gfc_new_symbol (name
, ns
);
2193 /* Add to the list of tentative symbols. */
2194 p
->old_symbol
= NULL
;
2195 p
->tlink
= changed_syms
;
2200 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2207 /* Make sure the existing symbol is OK. Ambiguous
2208 generic interfaces are permitted, as long as the
2209 specific interfaces are different. */
2210 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2212 ambiguous_symbol (name
, st
);
2218 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2220 /* Symbol is from another namespace. */
2221 gfc_error ("Symbol '%s' at %C has already been host associated",
2228 /* Copy in case this symbol is changed. */
2229 save_symbol_data (p
);
2238 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2244 i
= gfc_get_sym_tree (name
, ns
, &st
);
2249 *result
= st
->n
.sym
;
2256 /* Subroutine that searches for a symbol, creating it if it doesn't
2257 exist, but tries to host-associate the symbol if possible. */
2260 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2265 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2268 save_symbol_data (st
->n
.sym
);
2274 if (gfc_current_ns
->parent
!= NULL
)
2276 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2287 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2292 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2297 i
= gfc_get_ha_sym_tree (name
, &st
);
2300 *result
= st
->n
.sym
;
2307 /* Return true if both symbols could refer to the same data object. Does
2308 not take account of aliasing due to equivalence statements. */
2311 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2313 /* Aliasing isn't possible if the symbols have different base types. */
2314 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2317 /* Pointers can point to other pointers, target objects and allocatable
2318 objects. Two allocatable objects cannot share the same storage. */
2319 if (lsym
->attr
.pointer
2320 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2322 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2324 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2331 /* Undoes all the changes made to symbols in the current statement.
2332 This subroutine is made simpler due to the fact that attributes are
2333 never removed once added. */
2336 gfc_undo_symbols (void)
2338 gfc_symbol
*p
, *q
, *old
;
2340 for (p
= changed_syms
; p
; p
= q
)
2346 /* Symbol was new. */
2347 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2351 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2353 gfc_free_symbol (p
);
2357 /* Restore previous state of symbol. Just copy simple stuff. */
2359 old
= p
->old_symbol
;
2361 p
->ts
.type
= old
->ts
.type
;
2362 p
->ts
.kind
= old
->ts
.kind
;
2364 p
->attr
= old
->attr
;
2366 if (p
->value
!= old
->value
)
2368 gfc_free_expr (old
->value
);
2372 if (p
->as
!= old
->as
)
2375 gfc_free_array_spec (p
->as
);
2379 p
->generic
= old
->generic
;
2380 p
->component_access
= old
->component_access
;
2382 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2384 gfc_free_namelist (p
->namelist
);
2390 if (p
->namelist_tail
!= old
->namelist_tail
)
2392 gfc_free_namelist (old
->namelist_tail
);
2393 old
->namelist_tail
->next
= NULL
;
2397 p
->namelist_tail
= old
->namelist_tail
;
2399 if (p
->formal
!= old
->formal
)
2401 gfc_free_formal_arglist (p
->formal
);
2402 p
->formal
= old
->formal
;
2405 gfc_free (p
->old_symbol
);
2406 p
->old_symbol
= NULL
;
2410 changed_syms
= NULL
;
2414 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2415 components of old_symbol that might need deallocation are the "allocatables"
2416 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2417 namelist_tail. In case these differ between old_symbol and sym, it's just
2418 because sym->namelist has gotten a few more items. */
2421 free_old_symbol (gfc_symbol
* sym
)
2423 if (sym
->old_symbol
== NULL
)
2426 if (sym
->old_symbol
->as
!= sym
->as
)
2427 gfc_free_array_spec (sym
->old_symbol
->as
);
2429 if (sym
->old_symbol
->value
!= sym
->value
)
2430 gfc_free_expr (sym
->old_symbol
->value
);
2432 if (sym
->old_symbol
->formal
!= sym
->formal
)
2433 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2435 gfc_free (sym
->old_symbol
);
2436 sym
->old_symbol
= NULL
;
2440 /* Makes the changes made in the current statement permanent-- gets
2441 rid of undo information. */
2444 gfc_commit_symbols (void)
2448 for (p
= changed_syms
; p
; p
= q
)
2455 free_old_symbol (p
);
2457 changed_syms
= NULL
;
2461 /* Makes the changes made in one symbol permanent -- gets rid of undo
2465 gfc_commit_symbol (gfc_symbol
* sym
)
2469 if (changed_syms
== sym
)
2470 changed_syms
= sym
->tlink
;
2473 for (p
= changed_syms
; p
; p
= p
->tlink
)
2474 if (p
->tlink
== sym
)
2476 p
->tlink
= sym
->tlink
;
2485 free_old_symbol (sym
);
2489 /* Recursive function that deletes an entire tree and all the common
2490 head structures it points to. */
2493 free_common_tree (gfc_symtree
* common_tree
)
2495 if (common_tree
== NULL
)
2498 free_common_tree (common_tree
->left
);
2499 free_common_tree (common_tree
->right
);
2501 gfc_free (common_tree
);
2505 /* Recursive function that deletes an entire tree and all the user
2506 operator nodes that it contains. */
2509 free_uop_tree (gfc_symtree
* uop_tree
)
2512 if (uop_tree
== NULL
)
2515 free_uop_tree (uop_tree
->left
);
2516 free_uop_tree (uop_tree
->right
);
2518 gfc_free_interface (uop_tree
->n
.uop
->operator);
2520 gfc_free (uop_tree
->n
.uop
);
2521 gfc_free (uop_tree
);
2525 /* Recursive function that deletes an entire tree and all the symbols
2526 that it contains. */
2529 free_sym_tree (gfc_symtree
* sym_tree
)
2534 if (sym_tree
== NULL
)
2537 free_sym_tree (sym_tree
->left
);
2538 free_sym_tree (sym_tree
->right
);
2540 sym
= sym_tree
->n
.sym
;
2544 gfc_internal_error ("free_sym_tree(): Negative refs");
2546 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2548 /* As formal_ns contains a reference to sym, delete formal_ns just
2549 before the deletion of sym. */
2550 ns
= sym
->formal_ns
;
2551 sym
->formal_ns
= NULL
;
2552 gfc_free_namespace (ns
);
2554 else if (sym
->refs
== 0)
2556 /* Go ahead and delete the symbol. */
2557 gfc_free_symbol (sym
);
2560 gfc_free (sym_tree
);
2564 /* Free the derived type list. */
2567 gfc_free_dt_list (void)
2569 gfc_dt_list
*dt
, *n
;
2571 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2577 gfc_derived_types
= NULL
;
2581 /* Free the gfc_equiv_info's. */
2584 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2588 gfc_free_equiv_infos (s
->next
);
2593 /* Free the gfc_equiv_lists. */
2596 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2600 gfc_free_equiv_lists (l
->next
);
2601 gfc_free_equiv_infos (l
->equiv
);
2606 /* Free a namespace structure and everything below it. Interface
2607 lists associated with intrinsic operators are not freed. These are
2608 taken care of when a specific name is freed. */
2611 gfc_free_namespace (gfc_namespace
* ns
)
2613 gfc_charlen
*cl
, *cl2
;
2614 gfc_namespace
*p
, *q
;
2623 gcc_assert (ns
->refs
== 0);
2625 gfc_free_statements (ns
->code
);
2627 free_sym_tree (ns
->sym_root
);
2628 free_uop_tree (ns
->uop_root
);
2629 free_common_tree (ns
->common_root
);
2631 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2634 gfc_free_expr (cl
->length
);
2638 free_st_labels (ns
->st_labels
);
2640 gfc_free_equiv (ns
->equiv
);
2641 gfc_free_equiv_lists (ns
->equiv_lists
);
2643 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2644 gfc_free_interface (ns
->operator[i
]);
2646 gfc_free_data (ns
->data
);
2650 /* Recursively free any contained namespaces. */
2656 gfc_free_namespace (q
);
2662 gfc_symbol_init_2 (void)
2665 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2670 gfc_symbol_done_2 (void)
2673 gfc_free_namespace (gfc_current_ns
);
2674 gfc_current_ns
= NULL
;
2675 gfc_free_dt_list ();
2679 /* Clear mark bits from symbol nodes associated with a symtree node. */
2682 clear_sym_mark (gfc_symtree
* st
)
2685 st
->n
.sym
->mark
= 0;
2689 /* Recursively traverse the symtree nodes. */
2692 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2698 gfc_traverse_symtree (st
->left
, func
);
2699 gfc_traverse_symtree (st
->right
, func
);
2704 /* Recursive namespace traversal function. */
2707 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2713 if (st
->n
.sym
->mark
== 0)
2714 (*func
) (st
->n
.sym
);
2715 st
->n
.sym
->mark
= 1;
2717 traverse_ns (st
->left
, func
);
2718 traverse_ns (st
->right
, func
);
2722 /* Call a given function for all symbols in the namespace. We take
2723 care that each gfc_symbol node is called exactly once. */
2726 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2729 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2731 traverse_ns (ns
->sym_root
, func
);
2735 /* Return TRUE if the symbol is an automatic variable. */
2737 gfc_is_var_automatic (gfc_symbol
* sym
)
2739 /* Pointer and allocatable variables are never automatic. */
2740 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2742 /* Check for arrays with non-constant size. */
2743 if (sym
->attr
.dimension
&& sym
->as
2744 && !gfc_is_compile_time_shape (sym
->as
))
2746 /* Check for non-constant length character variables. */
2747 if (sym
->ts
.type
== BT_CHARACTER
2749 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2754 /* Given a symbol, mark it as SAVEd if it is allowed. */
2757 save_symbol (gfc_symbol
* sym
)
2760 if (sym
->attr
.use_assoc
)
2763 if (sym
->attr
.in_common
2765 || sym
->attr
.flavor
!= FL_VARIABLE
)
2767 /* Automatic objects are not saved. */
2768 if (gfc_is_var_automatic (sym
))
2770 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2774 /* Mark those symbols which can be SAVEd as such. */
2777 gfc_save_all (gfc_namespace
* ns
)
2780 gfc_traverse_ns (ns
, save_symbol
);
2785 /* Make sure that no changes to symbols are pending. */
2788 gfc_symbol_state(void) {
2790 if (changed_syms
!= NULL
)
2791 gfc_internal_error("Symbol changes still pending!");
2796 /************** Global symbol handling ************/
2799 /* Search a tree for the global symbol. */
2802 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2811 c
= strcmp (name
, symbol
->name
);
2815 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2822 /* Compare two global symbols. Used for managing the BB tree. */
2825 gsym_compare (void * _s1
, void * _s2
)
2827 gfc_gsymbol
*s1
, *s2
;
2829 s1
= (gfc_gsymbol
*)_s1
;
2830 s2
= (gfc_gsymbol
*)_s2
;
2831 return strcmp(s1
->name
, s2
->name
);
2835 /* Get a global symbol, creating it if it doesn't exist. */
2838 gfc_get_gsymbol (const char *name
)
2842 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2846 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2847 s
->type
= GSYM_UNKNOWN
;
2848 s
->name
= gfc_get_string (name
);
2850 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);