1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
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 /******************** Symbol attribute stuff *********************/
258 /* This is a generic conflict-checker. We do this to avoid having a
259 single conflict in two places. */
261 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
262 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
263 #define conf_std(a, b, std) if (attr->a && attr->b)\
272 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
274 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
275 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
276 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
277 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
278 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
279 *private = "PRIVATE", *recursive
= "RECURSIVE",
280 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
281 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
282 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
283 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
284 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
285 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
286 *volatile_
= "VOLATILE", *protected = "PROTECTED";
287 static const char *threadprivate
= "THREADPRIVATE";
293 where
= &gfc_current_locus
;
295 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
299 standard
= GFC_STD_F2003
;
303 /* Check for attributes not allowed in a BLOCK DATA. */
304 if (gfc_current_state () == COMP_BLOCK_DATA
)
308 if (attr
->in_namelist
)
310 if (attr
->allocatable
)
316 if (attr
->access
== ACCESS_PRIVATE
)
318 if (attr
->access
== ACCESS_PUBLIC
)
320 if (attr
->intent
!= INTENT_UNKNOWN
)
326 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
333 conf (dummy
, intrinsic
);
335 conf (dummy
, threadprivate
);
336 conf (pointer
, target
);
337 conf (pointer
, external
);
338 conf (pointer
, intrinsic
);
339 conf (pointer
, elemental
);
340 conf (allocatable
, elemental
);
342 conf (target
, external
);
343 conf (target
, intrinsic
);
344 conf (external
, dimension
); /* See Fortran 95's R504. */
346 conf (external
, intrinsic
);
348 if (attr
->if_source
|| attr
->contained
)
350 conf (external
, subroutine
);
351 conf (external
, function
);
354 conf (allocatable
, pointer
);
355 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
356 conf_std (allocatable
, function
, GFC_STD_F2003
);
357 conf_std (allocatable
, result
, GFC_STD_F2003
);
358 conf (elemental
, recursive
);
360 conf (in_common
, dummy
);
361 conf (in_common
, allocatable
);
362 conf (in_common
, result
);
363 conf (in_common
, save
);
366 conf (dummy
, result
);
368 conf (in_equivalence
, use_assoc
);
369 conf (in_equivalence
, dummy
);
370 conf (in_equivalence
, target
);
371 conf (in_equivalence
, pointer
);
372 conf (in_equivalence
, function
);
373 conf (in_equivalence
, result
);
374 conf (in_equivalence
, entry
);
375 conf (in_equivalence
, allocatable
);
376 conf (in_equivalence
, threadprivate
);
378 conf (in_namelist
, pointer
);
379 conf (in_namelist
, allocatable
);
381 conf (entry
, result
);
383 conf (function
, subroutine
);
385 /* Cray pointer/pointee conflicts. */
386 conf (cray_pointer
, cray_pointee
);
387 conf (cray_pointer
, dimension
);
388 conf (cray_pointer
, pointer
);
389 conf (cray_pointer
, target
);
390 conf (cray_pointer
, allocatable
);
391 conf (cray_pointer
, external
);
392 conf (cray_pointer
, intrinsic
);
393 conf (cray_pointer
, in_namelist
);
394 conf (cray_pointer
, function
);
395 conf (cray_pointer
, subroutine
);
396 conf (cray_pointer
, entry
);
398 conf (cray_pointee
, allocatable
);
399 conf (cray_pointee
, intent
);
400 conf (cray_pointee
, optional
);
401 conf (cray_pointee
, dummy
);
402 conf (cray_pointee
, target
);
403 conf (cray_pointee
, intrinsic
);
404 conf (cray_pointee
, pointer
);
405 conf (cray_pointee
, entry
);
406 conf (cray_pointee
, in_common
);
407 conf (cray_pointee
, in_equivalence
);
408 conf (cray_pointee
, threadprivate
);
411 conf (data
, function
);
413 conf (data
, allocatable
);
414 conf (data
, use_assoc
);
416 conf (protected, intrinsic
)
417 conf (protected, external
)
418 conf (protected, in_common
)
420 conf (value
, pointer
)
421 conf (value
, allocatable
)
422 conf (value
, subroutine
)
423 conf (value
, function
)
424 conf (value
, volatile_
)
425 conf (value
, dimension
)
426 conf (value
, external
)
428 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
431 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
435 conf (volatile_
, intrinsic
)
436 conf (volatile_
, external
)
438 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
445 a1
= gfc_code2string (flavors
, attr
->flavor
);
447 if (attr
->in_namelist
448 && attr
->flavor
!= FL_VARIABLE
449 && attr
->flavor
!= FL_UNKNOWN
)
456 switch (attr
->flavor
)
477 conf2 (threadprivate
);
488 if (attr
->subroutine
)
497 conf2(threadprivate
);
502 case PROC_ST_FUNCTION
:
515 conf2 (threadprivate
);
536 conf2 (threadprivate
);
538 if (attr
->intent
!= INTENT_UNKNOWN
)
561 conf2 (threadprivate
);
572 gfc_error ("%s attribute conflicts with %s attribute at %L",
575 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
576 a1
, a2
, name
, where
);
583 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
584 "with %s attribute at %L", a1
, a2
,
589 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
590 "with %s attribute in '%s' at %L",
591 a1
, a2
, name
, where
);
600 /* Mark a symbol as referenced. */
603 gfc_set_sym_referenced (gfc_symbol
* sym
)
605 if (sym
->attr
.referenced
)
608 sym
->attr
.referenced
= 1;
610 /* Remember which order dummy variables are accessed in. */
612 sym
->dummy_order
= next_dummy_order
++;
616 /* Common subroutine called by attribute changing subroutines in order
617 to prevent them from changing a symbol that has been
618 use-associated. Returns zero if it is OK to change the symbol,
622 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
625 if (attr
->use_assoc
== 0)
629 where
= &gfc_current_locus
;
632 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
635 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
642 /* Generate an error because of a duplicate attribute. */
645 duplicate_attr (const char *attr
, locus
* where
)
649 where
= &gfc_current_locus
;
651 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
654 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
657 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
659 if (check_used (attr
, NULL
, where
))
662 return check_conflict (attr
, NULL
, where
);
666 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
669 if (check_used (attr
, NULL
, where
))
672 if (attr
->allocatable
)
674 duplicate_attr ("ALLOCATABLE", where
);
678 attr
->allocatable
= 1;
679 return check_conflict (attr
, NULL
, where
);
684 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
687 if (check_used (attr
, name
, where
))
692 duplicate_attr ("DIMENSION", where
);
697 return check_conflict (attr
, name
, where
);
702 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
705 if (check_used (attr
, NULL
, where
))
710 duplicate_attr ("EXTERNAL", where
);
716 return check_conflict (attr
, NULL
, where
);
721 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
724 if (check_used (attr
, NULL
, where
))
729 duplicate_attr ("INTRINSIC", where
);
735 return check_conflict (attr
, NULL
, where
);
740 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
743 if (check_used (attr
, NULL
, where
))
748 duplicate_attr ("OPTIONAL", where
);
753 return check_conflict (attr
, NULL
, where
);
758 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
761 if (check_used (attr
, NULL
, where
))
765 return check_conflict (attr
, NULL
, where
);
770 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
773 if (check_used (attr
, NULL
, where
))
776 attr
->cray_pointer
= 1;
777 return check_conflict (attr
, NULL
, where
);
782 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
785 if (check_used (attr
, NULL
, where
))
788 if (attr
->cray_pointee
)
790 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
791 " statements", where
);
795 attr
->cray_pointee
= 1;
796 return check_conflict (attr
, NULL
, where
);
800 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
802 if (check_used (attr
, name
, where
))
807 if (gfc_notify_std (GFC_STD_LEGACY
,
808 "Duplicate PROTECTED attribute specified at %L",
815 return check_conflict (attr
, name
, where
);
819 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
822 if (check_used (attr
, name
, where
))
826 return check_conflict (attr
, name
, where
);
831 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
834 if (check_used (attr
, name
, where
))
840 ("SAVE attribute at %L cannot be specified in a PURE procedure",
847 if (gfc_notify_std (GFC_STD_LEGACY
,
848 "Duplicate SAVE attribute specified at %L",
855 return check_conflict (attr
, name
, where
);
859 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
862 if (check_used (attr
, name
, where
))
867 if (gfc_notify_std (GFC_STD_LEGACY
,
868 "Duplicate VALUE attribute specified at %L",
875 return check_conflict (attr
, name
, where
);
879 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
881 /* No check_used needed as 11.2.1 of the F2003 standard allows
882 that the local identifier made accessible by a use statement can be
883 given a VOLATILE attribute. */
885 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
886 if (gfc_notify_std (GFC_STD_LEGACY
,
887 "Duplicate VOLATILE attribute specified at %L", where
)
892 attr
->volatile_ns
= gfc_current_ns
;
893 return check_conflict (attr
, name
, where
);
898 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
900 if (check_used (attr
, name
, where
))
903 if (attr
->threadprivate
)
905 duplicate_attr ("THREADPRIVATE", where
);
909 attr
->threadprivate
= 1;
910 return check_conflict (attr
, name
, where
);
915 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
918 if (check_used (attr
, NULL
, where
))
923 duplicate_attr ("TARGET", where
);
928 return check_conflict (attr
, NULL
, where
);
933 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
936 if (check_used (attr
, name
, where
))
939 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
941 return check_conflict (attr
, name
, where
);
946 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
949 if (check_used (attr
, name
, where
))
952 /* Duplicate attribute already checked for. */
954 if (check_conflict (attr
, name
, where
) == FAILURE
)
957 if (attr
->flavor
== FL_VARIABLE
)
960 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
964 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
967 /* Duplicate attribute already checked for. */
968 attr
->in_equivalence
= 1;
969 if (check_conflict (attr
, name
, where
) == FAILURE
)
972 if (attr
->flavor
== FL_VARIABLE
)
975 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
980 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
983 if (check_used (attr
, name
, where
))
987 return check_conflict (attr
, name
, where
);
992 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
996 attr
->in_namelist
= 1;
997 return check_conflict (attr
, name
, where
);
1002 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
1005 if (check_used (attr
, name
, where
))
1009 return check_conflict (attr
, name
, where
);
1014 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1017 if (check_used (attr
, NULL
, where
))
1020 attr
->elemental
= 1;
1021 return check_conflict (attr
, NULL
, where
);
1026 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1029 if (check_used (attr
, NULL
, where
))
1033 return check_conflict (attr
, NULL
, where
);
1038 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1041 if (check_used (attr
, NULL
, where
))
1044 attr
->recursive
= 1;
1045 return check_conflict (attr
, NULL
, where
);
1050 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1053 if (check_used (attr
, name
, where
))
1058 duplicate_attr ("ENTRY", where
);
1063 return check_conflict (attr
, name
, where
);
1068 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1071 if (attr
->flavor
!= FL_PROCEDURE
1072 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1076 return check_conflict (attr
, name
, where
);
1081 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1084 if (attr
->flavor
!= FL_PROCEDURE
1085 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1088 attr
->subroutine
= 1;
1089 return check_conflict (attr
, name
, where
);
1094 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1097 if (attr
->flavor
!= FL_PROCEDURE
1098 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1102 return check_conflict (attr
, name
, where
);
1106 /* Flavors are special because some flavors are not what Fortran
1107 considers attributes and can be reaffirmed multiple times. */
1110 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1114 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1115 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1116 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1119 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1122 if (attr
->flavor
!= FL_UNKNOWN
)
1125 where
= &gfc_current_locus
;
1127 gfc_error ("%s attribute conflicts with %s attribute at %L",
1128 gfc_code2string (flavors
, attr
->flavor
),
1129 gfc_code2string (flavors
, f
), where
);
1136 return check_conflict (attr
, name
, where
);
1141 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1142 const char *name
, locus
* where
)
1145 if (check_used (attr
, name
, where
))
1148 if (attr
->flavor
!= FL_PROCEDURE
1149 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1153 where
= &gfc_current_locus
;
1155 if (attr
->proc
!= PROC_UNKNOWN
)
1157 gfc_error ("%s procedure at %L is already declared as %s procedure",
1158 gfc_code2string (procedures
, t
), where
,
1159 gfc_code2string (procedures
, attr
->proc
));
1166 /* Statement functions are always scalar and functions. */
1167 if (t
== PROC_ST_FUNCTION
1168 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1169 || attr
->dimension
))
1172 return check_conflict (attr
, name
, where
);
1177 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1180 if (check_used (attr
, NULL
, where
))
1183 if (attr
->intent
== INTENT_UNKNOWN
)
1185 attr
->intent
= intent
;
1186 return check_conflict (attr
, NULL
, where
);
1190 where
= &gfc_current_locus
;
1192 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1193 gfc_intent_string (attr
->intent
),
1194 gfc_intent_string (intent
), where
);
1200 /* No checks for use-association in public and private statements. */
1203 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1204 const char *name
, locus
* where
)
1207 if (attr
->access
== ACCESS_UNKNOWN
)
1209 attr
->access
= access
;
1210 return check_conflict (attr
, name
, where
);
1214 where
= &gfc_current_locus
;
1215 gfc_error ("ACCESS specification at %L was already specified", where
);
1222 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1223 gfc_formal_arglist
* formal
, locus
* where
)
1226 if (check_used (&sym
->attr
, sym
->name
, where
))
1230 where
= &gfc_current_locus
;
1232 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1233 && sym
->attr
.if_source
!= IFSRC_DECL
)
1235 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1240 sym
->formal
= formal
;
1241 sym
->attr
.if_source
= source
;
1247 /* Add a type to a symbol. */
1250 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1255 where
= &gfc_current_locus
;
1257 if (sym
->ts
.type
!= BT_UNKNOWN
)
1259 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1260 if (!(sym
->ts
.type
== ts
->type
1261 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1262 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1265 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1268 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1269 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1273 flavor
= sym
->attr
.flavor
;
1275 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1276 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1277 && sym
->attr
.subroutine
)
1278 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1280 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1289 /* Clears all attributes. */
1292 gfc_clear_attr (symbol_attribute
* attr
)
1294 memset (attr
, 0, sizeof(symbol_attribute
));
1298 /* Check for missing attributes in the new symbol. Currently does
1299 nothing, but it's not clear that it is unnecessary yet. */
1302 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1303 locus
* where ATTRIBUTE_UNUSED
)
1310 /* Copy an attribute to a symbol attribute, bit by bit. Some
1311 attributes have a lot of side-effects but cannot be present given
1312 where we are called from, so we ignore some bits. */
1315 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1318 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1321 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1323 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1325 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1327 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1329 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1331 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1333 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1335 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1337 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1339 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1341 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1346 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1349 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1352 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1354 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1356 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1359 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1361 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1363 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1365 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1368 if (src
->flavor
!= FL_UNKNOWN
1369 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1372 if (src
->intent
!= INTENT_UNKNOWN
1373 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1376 if (src
->access
!= ACCESS_UNKNOWN
1377 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1380 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1383 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1385 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1388 /* The subroutines that set these bits also cause flavors to be set,
1389 and that has already happened in the original, so don't let it
1394 dest
->intrinsic
= 1;
1403 /************** Component name management ************/
1405 /* Component names of a derived type form their own little namespaces
1406 that are separate from all other spaces. The space is composed of
1407 a singly linked list of gfc_component structures whose head is
1408 located in the parent symbol. */
1411 /* Add a component name to a symbol. The call fails if the name is
1412 already present. On success, the component pointer is modified to
1413 point to the additional component structure. */
1416 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1418 gfc_component
*p
, *tail
;
1422 for (p
= sym
->components
; p
; p
= p
->next
)
1424 if (strcmp (p
->name
, name
) == 0)
1426 gfc_error ("Component '%s' at %C already declared at %L",
1434 /* Allocate a new component. */
1435 p
= gfc_get_component ();
1438 sym
->components
= p
;
1442 p
->name
= gfc_get_string (name
);
1443 p
->loc
= gfc_current_locus
;
1450 /* Recursive function to switch derived types of all symbol in a
1454 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1462 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1463 sym
->ts
.derived
= to
;
1465 switch_types (st
->left
, from
, to
);
1466 switch_types (st
->right
, from
, to
);
1470 /* This subroutine is called when a derived type is used in order to
1471 make the final determination about which version to use. The
1472 standard requires that a type be defined before it is 'used', but
1473 such types can appear in IMPLICIT statements before the actual
1474 definition. 'Using' in this context means declaring a variable to
1475 be that type or using the type constructor.
1477 If a type is used and the components haven't been defined, then we
1478 have to have a derived type in a parent unit. We find the node in
1479 the other namespace and point the symtree node in this namespace to
1480 that node. Further reference to this name point to the correct
1481 node. If we can't find the node in a parent namespace, then we have
1484 This subroutine takes a pointer to a symbol node and returns a
1485 pointer to the translated node or NULL for an error. Usually there
1486 is no translation and we return the node we were passed. */
1489 gfc_use_derived (gfc_symbol
* sym
)
1496 if (sym
->components
!= NULL
)
1497 return sym
; /* Already defined. */
1499 if (sym
->ns
->parent
== NULL
)
1502 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1504 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1508 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1511 /* Get rid of symbol sym, translating all references to s. */
1512 for (i
= 0; i
< GFC_LETTERS
; i
++)
1514 t
= &sym
->ns
->default_type
[i
];
1515 if (t
->derived
== sym
)
1519 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1524 /* Unlink from list of modified symbols. */
1525 gfc_commit_symbol (sym
);
1527 switch_types (sym
->ns
->sym_root
, sym
, s
);
1529 /* TODO: Also have to replace sym -> s in other lists like
1530 namelists, common lists and interface lists. */
1531 gfc_free_symbol (sym
);
1536 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1542 /* Given a derived type node and a component name, try to locate the
1543 component structure. Returns the NULL pointer if the component is
1544 not found or the components are private. */
1547 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1554 sym
= gfc_use_derived (sym
);
1559 for (p
= sym
->components
; p
; p
= p
->next
)
1560 if (strcmp (p
->name
, name
) == 0)
1564 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1568 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1570 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1580 /* Given a symbol, free all of the component structures and everything
1584 free_components (gfc_component
* p
)
1592 gfc_free_array_spec (p
->as
);
1593 gfc_free_expr (p
->initializer
);
1600 /* Set component attributes from a standard symbol attribute
1604 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1607 c
->dimension
= attr
->dimension
;
1608 c
->pointer
= attr
->pointer
;
1609 c
->allocatable
= attr
->allocatable
;
1613 /* Get a standard symbol attribute structure given the component
1617 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1620 gfc_clear_attr (attr
);
1621 attr
->dimension
= c
->dimension
;
1622 attr
->pointer
= c
->pointer
;
1623 attr
->allocatable
= c
->allocatable
;
1627 /******************** Statement label management ********************/
1629 /* Comparison function for statement labels, used for managing the
1633 compare_st_labels (void * a1
, void * b1
)
1635 int a
= ((gfc_st_label
*)a1
)->value
;
1636 int b
= ((gfc_st_label
*)b1
)->value
;
1642 /* Free a single gfc_st_label structure, making sure the tree is not
1643 messed up. This function is called only when some parse error
1647 gfc_free_st_label (gfc_st_label
* label
)
1652 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1654 if (label
->format
!= NULL
)
1655 gfc_free_expr (label
->format
);
1660 /* Free a whole tree of gfc_st_label structures. */
1663 free_st_labels (gfc_st_label
* label
)
1668 free_st_labels (label
->left
);
1669 free_st_labels (label
->right
);
1671 if (label
->format
!= NULL
)
1672 gfc_free_expr (label
->format
);
1677 /* Given a label number, search for and return a pointer to the label
1678 structure, creating it if it does not exist. */
1681 gfc_get_st_label (int labelno
)
1685 /* First see if the label is already in this namespace. */
1686 lp
= gfc_current_ns
->st_labels
;
1689 if (lp
->value
== labelno
)
1692 if (lp
->value
< labelno
)
1698 lp
= gfc_getmem (sizeof (gfc_st_label
));
1700 lp
->value
= labelno
;
1701 lp
->defined
= ST_LABEL_UNKNOWN
;
1702 lp
->referenced
= ST_LABEL_UNKNOWN
;
1704 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1710 /* Called when a statement with a statement label is about to be
1711 accepted. We add the label to the list of the current namespace,
1712 making sure it hasn't been defined previously and referenced
1716 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1720 labelno
= lp
->value
;
1722 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1723 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1724 &lp
->where
, label_locus
);
1727 lp
->where
= *label_locus
;
1731 case ST_LABEL_FORMAT
:
1732 if (lp
->referenced
== ST_LABEL_TARGET
)
1733 gfc_error ("Label %d at %C already referenced as branch target",
1736 lp
->defined
= ST_LABEL_FORMAT
;
1740 case ST_LABEL_TARGET
:
1741 if (lp
->referenced
== ST_LABEL_FORMAT
)
1742 gfc_error ("Label %d at %C already referenced as a format label",
1745 lp
->defined
= ST_LABEL_TARGET
;
1750 lp
->defined
= ST_LABEL_BAD_TARGET
;
1751 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1757 /* Reference a label. Given a label and its type, see if that
1758 reference is consistent with what is known about that label,
1759 updating the unknown state. Returns FAILURE if something goes
1763 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1765 gfc_sl_type label_type
;
1772 labelno
= lp
->value
;
1774 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1775 label_type
= lp
->defined
;
1778 label_type
= lp
->referenced
;
1779 lp
->where
= gfc_current_locus
;
1782 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1784 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1789 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1790 && type
== ST_LABEL_FORMAT
)
1792 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1797 lp
->referenced
= type
;
1805 /************** Symbol table management subroutines ****************/
1807 /* Basic details: Fortran 95 requires a potentially unlimited number
1808 of distinct namespaces when compiling a program unit. This case
1809 occurs during a compilation of internal subprograms because all of
1810 the internal subprograms must be read before we can start
1811 generating code for the host.
1813 Given the tricky nature of the Fortran grammar, we must be able to
1814 undo changes made to a symbol table if the current interpretation
1815 of a statement is found to be incorrect. Whenever a symbol is
1816 looked up, we make a copy of it and link to it. All of these
1817 symbols are kept in a singly linked list so that we can commit or
1818 undo the changes at a later time.
1820 A symtree may point to a symbol node outside of its namespace. In
1821 this case, that symbol has been used as a host associated variable
1822 at some previous time. */
1824 /* Allocate a new namespace structure. Copies the implicit types from
1825 PARENT if PARENT_TYPES is set. */
1828 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1832 gfc_intrinsic_op in
;
1835 ns
= gfc_getmem (sizeof (gfc_namespace
));
1836 ns
->sym_root
= NULL
;
1837 ns
->uop_root
= NULL
;
1838 ns
->default_access
= ACCESS_UNKNOWN
;
1839 ns
->parent
= parent
;
1841 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1842 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1844 /* Initialize default implicit types. */
1845 for (i
= 'a'; i
<= 'z'; i
++)
1847 ns
->set_flag
[i
- 'a'] = 0;
1848 ts
= &ns
->default_type
[i
- 'a'];
1850 if (parent_types
&& ns
->parent
!= NULL
)
1852 /* Copy parent settings */
1853 *ts
= ns
->parent
->default_type
[i
- 'a'];
1857 if (gfc_option
.flag_implicit_none
!= 0)
1863 if ('i' <= i
&& i
<= 'n')
1865 ts
->type
= BT_INTEGER
;
1866 ts
->kind
= gfc_default_integer_kind
;
1871 ts
->kind
= gfc_default_real_kind
;
1881 /* Comparison function for symtree nodes. */
1884 compare_symtree (void * _st1
, void * _st2
)
1886 gfc_symtree
*st1
, *st2
;
1888 st1
= (gfc_symtree
*) _st1
;
1889 st2
= (gfc_symtree
*) _st2
;
1891 return strcmp (st1
->name
, st2
->name
);
1895 /* Allocate a new symtree node and associate it with the new symbol. */
1898 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1902 st
= gfc_getmem (sizeof (gfc_symtree
));
1903 st
->name
= gfc_get_string (name
);
1905 gfc_insert_bbt (root
, st
, compare_symtree
);
1910 /* Delete a symbol from the tree. Does not free the symbol itself! */
1913 delete_symtree (gfc_symtree
** root
, const char *name
)
1915 gfc_symtree st
, *st0
;
1917 st0
= gfc_find_symtree (*root
, name
);
1919 st
.name
= gfc_get_string (name
);
1920 gfc_delete_bbt (root
, &st
, compare_symtree
);
1926 /* Given a root symtree node and a name, try to find the symbol within
1927 the namespace. Returns NULL if the symbol is not found. */
1930 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1936 c
= strcmp (name
, st
->name
);
1940 st
= (c
< 0) ? st
->left
: st
->right
;
1947 /* Given a name find a user operator node, creating it if it doesn't
1948 exist. These are much simpler than symbols because they can't be
1949 ambiguous with one another. */
1952 gfc_get_uop (const char *name
)
1957 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1961 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1963 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1964 uop
->name
= gfc_get_string (name
);
1965 uop
->access
= ACCESS_UNKNOWN
;
1966 uop
->ns
= gfc_current_ns
;
1972 /* Given a name find the user operator node. Returns NULL if it does
1976 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1981 ns
= gfc_current_ns
;
1983 st
= gfc_find_symtree (ns
->uop_root
, name
);
1984 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1988 /* Remove a gfc_symbol structure and everything it points to. */
1991 gfc_free_symbol (gfc_symbol
* sym
)
1997 gfc_free_array_spec (sym
->as
);
1999 free_components (sym
->components
);
2001 gfc_free_expr (sym
->value
);
2003 gfc_free_namelist (sym
->namelist
);
2005 gfc_free_namespace (sym
->formal_ns
);
2007 if (!sym
->attr
.generic_copy
)
2008 gfc_free_interface (sym
->generic
);
2010 gfc_free_formal_arglist (sym
->formal
);
2016 /* Allocate and initialize a new symbol node. */
2019 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2023 p
= gfc_getmem (sizeof (gfc_symbol
));
2025 gfc_clear_ts (&p
->ts
);
2026 gfc_clear_attr (&p
->attr
);
2029 p
->declared_at
= gfc_current_locus
;
2031 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2032 gfc_internal_error ("new_symbol(): Symbol name too long");
2034 p
->name
= gfc_get_string (name
);
2039 /* Generate an error if a symbol is ambiguous. */
2042 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2045 if (st
->n
.sym
->module
)
2046 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2047 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2049 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2050 "from current program unit", name
, st
->n
.sym
->name
);
2054 /* Search for a symtree starting in the current namespace, resorting to
2055 any parent namespaces if requested by a nonzero parent_flag.
2056 Returns nonzero if the name is ambiguous. */
2059 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2060 gfc_symtree
** result
)
2065 ns
= gfc_current_ns
;
2069 st
= gfc_find_symtree (ns
->sym_root
, name
);
2073 /* Ambiguous generic interfaces are permitted, as long
2074 as the specific interfaces are different. */
2075 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2077 ambiguous_symbol (name
, st
);
2096 /* Same, but returns the symbol instead. */
2099 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2100 gfc_symbol
** result
)
2105 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2110 *result
= st
->n
.sym
;
2116 /* Save symbol with the information necessary to back it out. */
2119 save_symbol_data (gfc_symbol
* sym
)
2122 if (sym
->new || sym
->old_symbol
!= NULL
)
2125 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2126 *(sym
->old_symbol
) = *sym
;
2128 sym
->tlink
= changed_syms
;
2133 /* Given a name, find a symbol, or create it if it does not exist yet
2134 in the current namespace. If the symbol is found we make sure that
2137 The integer return code indicates
2139 1 The symbol name was ambiguous
2140 2 The name meant to be established was already host associated.
2142 So if the return value is nonzero, then an error was issued. */
2145 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2150 /* This doesn't usually happen during resolution. */
2152 ns
= gfc_current_ns
;
2154 /* Try to find the symbol in ns. */
2155 st
= gfc_find_symtree (ns
->sym_root
, name
);
2159 /* If not there, create a new symbol. */
2160 p
= gfc_new_symbol (name
, ns
);
2162 /* Add to the list of tentative symbols. */
2163 p
->old_symbol
= NULL
;
2164 p
->tlink
= changed_syms
;
2169 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2176 /* Make sure the existing symbol is OK. Ambiguous
2177 generic interfaces are permitted, as long as the
2178 specific interfaces are different. */
2179 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2181 ambiguous_symbol (name
, st
);
2187 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2189 /* Symbol is from another namespace. */
2190 gfc_error ("Symbol '%s' at %C has already been host associated",
2197 /* Copy in case this symbol is changed. */
2198 save_symbol_data (p
);
2207 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2213 i
= gfc_get_sym_tree (name
, ns
, &st
);
2218 *result
= st
->n
.sym
;
2225 /* Subroutine that searches for a symbol, creating it if it doesn't
2226 exist, but tries to host-associate the symbol if possible. */
2229 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2234 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2237 save_symbol_data (st
->n
.sym
);
2243 if (gfc_current_ns
->parent
!= NULL
)
2245 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2256 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2261 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2266 i
= gfc_get_ha_sym_tree (name
, &st
);
2269 *result
= st
->n
.sym
;
2276 /* Return true if both symbols could refer to the same data object. Does
2277 not take account of aliasing due to equivalence statements. */
2280 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2282 /* Aliasing isn't possible if the symbols have different base types. */
2283 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2286 /* Pointers can point to other pointers, target objects and allocatable
2287 objects. Two allocatable objects cannot share the same storage. */
2288 if (lsym
->attr
.pointer
2289 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2291 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2293 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2300 /* Undoes all the changes made to symbols in the current statement.
2301 This subroutine is made simpler due to the fact that attributes are
2302 never removed once added. */
2305 gfc_undo_symbols (void)
2307 gfc_symbol
*p
, *q
, *old
;
2309 for (p
= changed_syms
; p
; p
= q
)
2315 /* Symbol was new. */
2316 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2320 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2322 gfc_free_symbol (p
);
2326 /* Restore previous state of symbol. Just copy simple stuff. */
2328 old
= p
->old_symbol
;
2330 p
->ts
.type
= old
->ts
.type
;
2331 p
->ts
.kind
= old
->ts
.kind
;
2333 p
->attr
= old
->attr
;
2335 if (p
->value
!= old
->value
)
2337 gfc_free_expr (old
->value
);
2341 if (p
->as
!= old
->as
)
2344 gfc_free_array_spec (p
->as
);
2348 p
->generic
= old
->generic
;
2349 p
->component_access
= old
->component_access
;
2351 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2353 gfc_free_namelist (p
->namelist
);
2359 if (p
->namelist_tail
!= old
->namelist_tail
)
2361 gfc_free_namelist (old
->namelist_tail
);
2362 old
->namelist_tail
->next
= NULL
;
2366 p
->namelist_tail
= old
->namelist_tail
;
2368 if (p
->formal
!= old
->formal
)
2370 gfc_free_formal_arglist (p
->formal
);
2371 p
->formal
= old
->formal
;
2374 gfc_free (p
->old_symbol
);
2375 p
->old_symbol
= NULL
;
2379 changed_syms
= NULL
;
2383 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2384 components of old_symbol that might need deallocation are the "allocatables"
2385 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2386 namelist_tail. In case these differ between old_symbol and sym, it's just
2387 because sym->namelist has gotten a few more items. */
2390 free_old_symbol (gfc_symbol
* sym
)
2392 if (sym
->old_symbol
== NULL
)
2395 if (sym
->old_symbol
->as
!= sym
->as
)
2396 gfc_free_array_spec (sym
->old_symbol
->as
);
2398 if (sym
->old_symbol
->value
!= sym
->value
)
2399 gfc_free_expr (sym
->old_symbol
->value
);
2401 if (sym
->old_symbol
->formal
!= sym
->formal
)
2402 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2404 gfc_free (sym
->old_symbol
);
2405 sym
->old_symbol
= NULL
;
2409 /* Makes the changes made in the current statement permanent-- gets
2410 rid of undo information. */
2413 gfc_commit_symbols (void)
2417 for (p
= changed_syms
; p
; p
= q
)
2424 free_old_symbol (p
);
2426 changed_syms
= NULL
;
2430 /* Makes the changes made in one symbol permanent -- gets rid of undo
2434 gfc_commit_symbol (gfc_symbol
* sym
)
2438 if (changed_syms
== sym
)
2439 changed_syms
= sym
->tlink
;
2442 for (p
= changed_syms
; p
; p
= p
->tlink
)
2443 if (p
->tlink
== sym
)
2445 p
->tlink
= sym
->tlink
;
2454 free_old_symbol (sym
);
2458 /* Recursive function that deletes an entire tree and all the common
2459 head structures it points to. */
2462 free_common_tree (gfc_symtree
* common_tree
)
2464 if (common_tree
== NULL
)
2467 free_common_tree (common_tree
->left
);
2468 free_common_tree (common_tree
->right
);
2470 gfc_free (common_tree
);
2474 /* Recursive function that deletes an entire tree and all the user
2475 operator nodes that it contains. */
2478 free_uop_tree (gfc_symtree
* uop_tree
)
2481 if (uop_tree
== NULL
)
2484 free_uop_tree (uop_tree
->left
);
2485 free_uop_tree (uop_tree
->right
);
2487 gfc_free_interface (uop_tree
->n
.uop
->operator);
2489 gfc_free (uop_tree
->n
.uop
);
2490 gfc_free (uop_tree
);
2494 /* Recursive function that deletes an entire tree and all the symbols
2495 that it contains. */
2498 free_sym_tree (gfc_symtree
* sym_tree
)
2503 if (sym_tree
== NULL
)
2506 free_sym_tree (sym_tree
->left
);
2507 free_sym_tree (sym_tree
->right
);
2509 sym
= sym_tree
->n
.sym
;
2513 gfc_internal_error ("free_sym_tree(): Negative refs");
2515 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2517 /* As formal_ns contains a reference to sym, delete formal_ns just
2518 before the deletion of sym. */
2519 ns
= sym
->formal_ns
;
2520 sym
->formal_ns
= NULL
;
2521 gfc_free_namespace (ns
);
2523 else if (sym
->refs
== 0)
2525 /* Go ahead and delete the symbol. */
2526 gfc_free_symbol (sym
);
2529 gfc_free (sym_tree
);
2533 /* Free the derived type list. */
2536 gfc_free_dt_list (void)
2538 gfc_dt_list
*dt
, *n
;
2540 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2546 gfc_derived_types
= NULL
;
2550 /* Free the gfc_equiv_info's. */
2553 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2557 gfc_free_equiv_infos (s
->next
);
2562 /* Free the gfc_equiv_lists. */
2565 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2569 gfc_free_equiv_lists (l
->next
);
2570 gfc_free_equiv_infos (l
->equiv
);
2575 /* Free a namespace structure and everything below it. Interface
2576 lists associated with intrinsic operators are not freed. These are
2577 taken care of when a specific name is freed. */
2580 gfc_free_namespace (gfc_namespace
* ns
)
2582 gfc_charlen
*cl
, *cl2
;
2583 gfc_namespace
*p
, *q
;
2592 gcc_assert (ns
->refs
== 0);
2594 gfc_free_statements (ns
->code
);
2596 free_sym_tree (ns
->sym_root
);
2597 free_uop_tree (ns
->uop_root
);
2598 free_common_tree (ns
->common_root
);
2600 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2603 gfc_free_expr (cl
->length
);
2607 free_st_labels (ns
->st_labels
);
2609 gfc_free_equiv (ns
->equiv
);
2610 gfc_free_equiv_lists (ns
->equiv_lists
);
2612 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2613 gfc_free_interface (ns
->operator[i
]);
2615 gfc_free_data (ns
->data
);
2619 /* Recursively free any contained namespaces. */
2625 gfc_free_namespace (q
);
2631 gfc_symbol_init_2 (void)
2634 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2639 gfc_symbol_done_2 (void)
2642 gfc_free_namespace (gfc_current_ns
);
2643 gfc_current_ns
= NULL
;
2644 gfc_free_dt_list ();
2648 /* Clear mark bits from symbol nodes associated with a symtree node. */
2651 clear_sym_mark (gfc_symtree
* st
)
2654 st
->n
.sym
->mark
= 0;
2658 /* Recursively traverse the symtree nodes. */
2661 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2667 gfc_traverse_symtree (st
->left
, func
);
2668 gfc_traverse_symtree (st
->right
, func
);
2673 /* Recursive namespace traversal function. */
2676 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2682 if (st
->n
.sym
->mark
== 0)
2683 (*func
) (st
->n
.sym
);
2684 st
->n
.sym
->mark
= 1;
2686 traverse_ns (st
->left
, func
);
2687 traverse_ns (st
->right
, func
);
2691 /* Call a given function for all symbols in the namespace. We take
2692 care that each gfc_symbol node is called exactly once. */
2695 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2698 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2700 traverse_ns (ns
->sym_root
, func
);
2704 /* Return TRUE if the symbol is an automatic variable. */
2706 gfc_is_var_automatic (gfc_symbol
* sym
)
2708 /* Pointer and allocatable variables are never automatic. */
2709 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2711 /* Check for arrays with non-constant size. */
2712 if (sym
->attr
.dimension
&& sym
->as
2713 && !gfc_is_compile_time_shape (sym
->as
))
2715 /* Check for non-constant length character variables. */
2716 if (sym
->ts
.type
== BT_CHARACTER
2718 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2723 /* Given a symbol, mark it as SAVEd if it is allowed. */
2726 save_symbol (gfc_symbol
* sym
)
2729 if (sym
->attr
.use_assoc
)
2732 if (sym
->attr
.in_common
2734 || sym
->attr
.flavor
!= FL_VARIABLE
)
2736 /* Automatic objects are not saved. */
2737 if (gfc_is_var_automatic (sym
))
2739 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2743 /* Mark those symbols which can be SAVEd as such. */
2746 gfc_save_all (gfc_namespace
* ns
)
2749 gfc_traverse_ns (ns
, save_symbol
);
2754 /* Make sure that no changes to symbols are pending. */
2757 gfc_symbol_state(void) {
2759 if (changed_syms
!= NULL
)
2760 gfc_internal_error("Symbol changes still pending!");
2765 /************** Global symbol handling ************/
2768 /* Search a tree for the global symbol. */
2771 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2777 if (strcmp (symbol
->name
, name
) == 0)
2780 s
= gfc_find_gsymbol (symbol
->left
, name
);
2784 s
= gfc_find_gsymbol (symbol
->right
, name
);
2792 /* Compare two global symbols. Used for managing the BB tree. */
2795 gsym_compare (void * _s1
, void * _s2
)
2797 gfc_gsymbol
*s1
, *s2
;
2799 s1
= (gfc_gsymbol
*)_s1
;
2800 s2
= (gfc_gsymbol
*)_s2
;
2801 return strcmp(s1
->name
, s2
->name
);
2805 /* Get a global symbol, creating it if it doesn't exist. */
2808 gfc_get_gsymbol (const char *name
)
2812 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2816 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2817 s
->type
= GSYM_UNKNOWN
;
2818 s
->name
= gfc_get_string (name
);
2820 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);