1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
97 /* The following static variable indicates whether a particular element has
98 been explicitly set or not. */
100 static int new_flag
[GFC_LETTERS
];
103 /* Handle a correctly parsed IMPLICIT NONE. */
106 gfc_set_implicit_none (void)
110 if (gfc_current_ns
->seen_implicit_none
)
112 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
116 gfc_current_ns
->seen_implicit_none
= 1;
118 for (i
= 0; i
< GFC_LETTERS
; i
++)
120 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
121 gfc_current_ns
->set_flag
[i
] = 1;
126 /* Reset the implicit range flags. */
129 gfc_clear_new_implicit (void)
133 for (i
= 0; i
< GFC_LETTERS
; i
++)
138 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
141 gfc_add_new_implicit_range (int c1
, int c2
)
148 for (i
= c1
; i
<= c2
; i
++)
152 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
165 the new implicit types back into the existing types will work. */
168 gfc_merge_new_implicit (gfc_typespec
* ts
)
172 if (gfc_current_ns
->seen_implicit_none
)
174 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
178 for (i
= 0; i
< GFC_LETTERS
; i
++)
183 if (gfc_current_ns
->set_flag
[i
])
185 gfc_error ("Letter %c already has an IMPLICIT type at %C",
189 gfc_current_ns
->default_type
[i
] = *ts
;
190 gfc_current_ns
->set_flag
[i
] = 1;
197 /* Given a symbol, return a pointer to the typespec for its default type. */
200 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
204 letter
= sym
->name
[0];
206 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
207 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
208 "gfortran developers, and should not be used for "
209 "implicitly typed variables");
211 if (letter
< 'a' || letter
> 'z')
212 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
217 return &ns
->default_type
[letter
- 'a'];
221 /* Given a pointer to a symbol, set its type according to the first
222 letter of its name. Fails if the letter in question has no default
226 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
230 if (sym
->ts
.type
!= BT_UNKNOWN
)
231 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
233 ts
= gfc_get_default_type (sym
, ns
);
235 if (ts
->type
== BT_UNKNOWN
)
237 if (error_flag
&& !sym
->attr
.untyped
)
239 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
240 sym
->name
, &sym
->declared_at
);
241 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
248 sym
->attr
.implicit_type
= 1;
254 /******************** Symbol attribute stuff *********************/
256 /* This is a generic conflict-checker. We do this to avoid having a
257 single conflict in two places. */
259 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
260 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
261 #define conf_std(a, b, std) if (attr->a && attr->b)\
270 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
272 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
273 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
274 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
275 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
276 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
277 *private = "PRIVATE", *recursive
= "RECURSIVE",
278 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
279 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
280 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
281 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
282 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
283 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
284 *volatile_
= "VOLATILE", *protected = "PROTECTED";
285 static const char *threadprivate
= "THREADPRIVATE";
291 where
= &gfc_current_locus
;
293 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
297 standard
= GFC_STD_F2003
;
301 /* Check for attributes not allowed in a BLOCK DATA. */
302 if (gfc_current_state () == COMP_BLOCK_DATA
)
306 if (attr
->in_namelist
)
308 if (attr
->allocatable
)
314 if (attr
->access
== ACCESS_PRIVATE
)
316 if (attr
->access
== ACCESS_PUBLIC
)
318 if (attr
->intent
!= INTENT_UNKNOWN
)
324 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
331 conf (dummy
, intrinsic
);
333 conf (dummy
, threadprivate
);
334 conf (pointer
, target
);
335 conf (pointer
, external
);
336 conf (pointer
, intrinsic
);
337 conf (pointer
, elemental
);
338 conf (allocatable
, elemental
);
340 conf (target
, external
);
341 conf (target
, intrinsic
);
342 conf (external
, dimension
); /* See Fortran 95's R504. */
344 conf (external
, intrinsic
);
346 if (attr
->if_source
|| attr
->contained
)
348 conf (external
, subroutine
);
349 conf (external
, function
);
352 conf (allocatable
, pointer
);
353 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
354 conf_std (allocatable
, function
, GFC_STD_F2003
);
355 conf_std (allocatable
, result
, GFC_STD_F2003
);
356 conf (elemental
, recursive
);
358 conf (in_common
, dummy
);
359 conf (in_common
, allocatable
);
360 conf (in_common
, result
);
361 conf (in_common
, save
);
364 conf (dummy
, result
);
366 conf (in_equivalence
, use_assoc
);
367 conf (in_equivalence
, dummy
);
368 conf (in_equivalence
, target
);
369 conf (in_equivalence
, pointer
);
370 conf (in_equivalence
, function
);
371 conf (in_equivalence
, result
);
372 conf (in_equivalence
, entry
);
373 conf (in_equivalence
, allocatable
);
374 conf (in_equivalence
, threadprivate
);
376 conf (in_namelist
, pointer
);
377 conf (in_namelist
, allocatable
);
379 conf (entry
, result
);
381 conf (function
, subroutine
);
383 /* Cray pointer/pointee conflicts. */
384 conf (cray_pointer
, cray_pointee
);
385 conf (cray_pointer
, dimension
);
386 conf (cray_pointer
, pointer
);
387 conf (cray_pointer
, target
);
388 conf (cray_pointer
, allocatable
);
389 conf (cray_pointer
, external
);
390 conf (cray_pointer
, intrinsic
);
391 conf (cray_pointer
, in_namelist
);
392 conf (cray_pointer
, function
);
393 conf (cray_pointer
, subroutine
);
394 conf (cray_pointer
, entry
);
396 conf (cray_pointee
, allocatable
);
397 conf (cray_pointee
, intent
);
398 conf (cray_pointee
, optional
);
399 conf (cray_pointee
, dummy
);
400 conf (cray_pointee
, target
);
401 conf (cray_pointee
, intrinsic
);
402 conf (cray_pointee
, pointer
);
403 conf (cray_pointee
, entry
);
404 conf (cray_pointee
, in_common
);
405 conf (cray_pointee
, in_equivalence
);
406 conf (cray_pointee
, threadprivate
);
409 conf (data
, function
);
411 conf (data
, allocatable
);
412 conf (data
, use_assoc
);
414 conf (protected, intrinsic
)
415 conf (protected, external
)
416 conf (protected, in_common
)
418 conf (value
, pointer
)
419 conf (value
, allocatable
)
420 conf (value
, subroutine
)
421 conf (value
, function
)
422 conf (value
, volatile_
)
423 conf (value
, dimension
)
424 conf (value
, external
)
426 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
429 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
433 conf (volatile_
, intrinsic
)
434 conf (volatile_
, external
)
436 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
443 a1
= gfc_code2string (flavors
, attr
->flavor
);
445 if (attr
->in_namelist
446 && attr
->flavor
!= FL_VARIABLE
447 && attr
->flavor
!= FL_UNKNOWN
)
454 switch (attr
->flavor
)
475 conf2 (threadprivate
);
486 if (attr
->subroutine
)
495 conf2(threadprivate
);
500 case PROC_ST_FUNCTION
:
513 conf2 (threadprivate
);
534 conf2 (threadprivate
);
536 if (attr
->intent
!= INTENT_UNKNOWN
)
559 conf2 (threadprivate
);
570 gfc_error ("%s attribute conflicts with %s attribute at %L",
573 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
574 a1
, a2
, name
, where
);
581 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
582 "with %s attribute at %L", a1
, a2
,
587 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
588 "with %s attribute in '%s' at %L",
589 a1
, a2
, name
, where
);
598 /* Mark a symbol as referenced. */
601 gfc_set_sym_referenced (gfc_symbol
* sym
)
603 if (sym
->attr
.referenced
)
606 sym
->attr
.referenced
= 1;
608 /* Remember which order dummy variables are accessed in. */
610 sym
->dummy_order
= next_dummy_order
++;
614 /* Common subroutine called by attribute changing subroutines in order
615 to prevent them from changing a symbol that has been
616 use-associated. Returns zero if it is OK to change the symbol,
620 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
623 if (attr
->use_assoc
== 0)
627 where
= &gfc_current_locus
;
630 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
633 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
640 /* Generate an error because of a duplicate attribute. */
643 duplicate_attr (const char *attr
, locus
* where
)
647 where
= &gfc_current_locus
;
649 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
652 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
655 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
657 if (check_used (attr
, NULL
, where
))
660 return check_conflict (attr
, NULL
, where
);
664 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
667 if (check_used (attr
, NULL
, where
))
670 if (attr
->allocatable
)
672 duplicate_attr ("ALLOCATABLE", where
);
676 attr
->allocatable
= 1;
677 return check_conflict (attr
, NULL
, where
);
682 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
685 if (check_used (attr
, name
, where
))
690 duplicate_attr ("DIMENSION", where
);
695 return check_conflict (attr
, name
, where
);
700 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
703 if (check_used (attr
, NULL
, where
))
708 duplicate_attr ("EXTERNAL", where
);
714 return check_conflict (attr
, NULL
, where
);
719 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
722 if (check_used (attr
, NULL
, where
))
727 duplicate_attr ("INTRINSIC", where
);
733 return check_conflict (attr
, NULL
, where
);
738 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
741 if (check_used (attr
, NULL
, where
))
746 duplicate_attr ("OPTIONAL", where
);
751 return check_conflict (attr
, NULL
, where
);
756 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
759 if (check_used (attr
, NULL
, where
))
763 return check_conflict (attr
, NULL
, where
);
768 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
771 if (check_used (attr
, NULL
, where
))
774 attr
->cray_pointer
= 1;
775 return check_conflict (attr
, NULL
, where
);
780 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
783 if (check_used (attr
, NULL
, where
))
786 if (attr
->cray_pointee
)
788 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
789 " statements", where
);
793 attr
->cray_pointee
= 1;
794 return check_conflict (attr
, NULL
, where
);
798 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
800 if (check_used (attr
, name
, where
))
805 if (gfc_notify_std (GFC_STD_LEGACY
,
806 "Duplicate PROTECTED attribute specified at %L",
813 return check_conflict (attr
, name
, where
);
817 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
820 if (check_used (attr
, name
, where
))
824 return check_conflict (attr
, name
, where
);
829 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
832 if (check_used (attr
, name
, where
))
838 ("SAVE attribute at %L cannot be specified in a PURE procedure",
845 if (gfc_notify_std (GFC_STD_LEGACY
,
846 "Duplicate SAVE attribute specified at %L",
853 return check_conflict (attr
, name
, where
);
857 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
860 if (check_used (attr
, name
, where
))
865 if (gfc_notify_std (GFC_STD_LEGACY
,
866 "Duplicate VALUE attribute specified at %L",
873 return check_conflict (attr
, name
, where
);
877 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
880 /* No check_used needed as 11.2.1 of the F2003 standard allows
881 that the local identifier made accessible by a use statement can be
882 given a VOLATILE attribute. */
884 /* TODO: The following allows multiple VOLATILE statements for
885 use-associated variables and it prevents setting VOLATILE for a host-
886 associated variable which is already marked as VOLATILE in the host. */
887 if (attr
->volatile_
&& !attr
->use_assoc
)
889 if (gfc_notify_std (GFC_STD_LEGACY
,
890 "Duplicate VOLATILE attribute specified at %L",
897 return check_conflict (attr
, name
, where
);
902 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
904 if (check_used (attr
, name
, where
))
907 if (attr
->threadprivate
)
909 duplicate_attr ("THREADPRIVATE", where
);
913 attr
->threadprivate
= 1;
914 return check_conflict (attr
, name
, where
);
919 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
922 if (check_used (attr
, NULL
, where
))
927 duplicate_attr ("TARGET", where
);
932 return check_conflict (attr
, NULL
, where
);
937 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
940 if (check_used (attr
, name
, where
))
943 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
945 return check_conflict (attr
, name
, where
);
950 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
953 if (check_used (attr
, name
, where
))
956 /* Duplicate attribute already checked for. */
958 if (check_conflict (attr
, name
, where
) == FAILURE
)
961 if (attr
->flavor
== FL_VARIABLE
)
964 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
968 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
971 /* Duplicate attribute already checked for. */
972 attr
->in_equivalence
= 1;
973 if (check_conflict (attr
, name
, where
) == FAILURE
)
976 if (attr
->flavor
== FL_VARIABLE
)
979 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
984 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
987 if (check_used (attr
, name
, where
))
991 return check_conflict (attr
, name
, where
);
996 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
1000 attr
->in_namelist
= 1;
1001 return check_conflict (attr
, name
, where
);
1006 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
1009 if (check_used (attr
, name
, where
))
1013 return check_conflict (attr
, name
, where
);
1018 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1021 if (check_used (attr
, NULL
, where
))
1024 attr
->elemental
= 1;
1025 return check_conflict (attr
, NULL
, where
);
1030 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1033 if (check_used (attr
, NULL
, where
))
1037 return check_conflict (attr
, NULL
, where
);
1042 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1045 if (check_used (attr
, NULL
, where
))
1048 attr
->recursive
= 1;
1049 return check_conflict (attr
, NULL
, where
);
1054 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1057 if (check_used (attr
, name
, where
))
1062 duplicate_attr ("ENTRY", where
);
1067 return check_conflict (attr
, name
, where
);
1072 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1075 if (attr
->flavor
!= FL_PROCEDURE
1076 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1080 return check_conflict (attr
, name
, where
);
1085 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1088 if (attr
->flavor
!= FL_PROCEDURE
1089 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1092 attr
->subroutine
= 1;
1093 return check_conflict (attr
, name
, where
);
1098 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1101 if (attr
->flavor
!= FL_PROCEDURE
1102 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1106 return check_conflict (attr
, name
, where
);
1110 /* Flavors are special because some flavors are not what Fortran
1111 considers attributes and can be reaffirmed multiple times. */
1114 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1118 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1119 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1120 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1123 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1126 if (attr
->flavor
!= FL_UNKNOWN
)
1129 where
= &gfc_current_locus
;
1131 gfc_error ("%s attribute conflicts with %s attribute at %L",
1132 gfc_code2string (flavors
, attr
->flavor
),
1133 gfc_code2string (flavors
, f
), where
);
1140 return check_conflict (attr
, name
, where
);
1145 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1146 const char *name
, locus
* where
)
1149 if (check_used (attr
, name
, where
))
1152 if (attr
->flavor
!= FL_PROCEDURE
1153 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1157 where
= &gfc_current_locus
;
1159 if (attr
->proc
!= PROC_UNKNOWN
)
1161 gfc_error ("%s procedure at %L is already declared as %s procedure",
1162 gfc_code2string (procedures
, t
), where
,
1163 gfc_code2string (procedures
, attr
->proc
));
1170 /* Statement functions are always scalar and functions. */
1171 if (t
== PROC_ST_FUNCTION
1172 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1173 || attr
->dimension
))
1176 return check_conflict (attr
, name
, where
);
1181 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1184 if (check_used (attr
, NULL
, where
))
1187 if (attr
->intent
== INTENT_UNKNOWN
)
1189 attr
->intent
= intent
;
1190 return check_conflict (attr
, NULL
, where
);
1194 where
= &gfc_current_locus
;
1196 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1197 gfc_intent_string (attr
->intent
),
1198 gfc_intent_string (intent
), where
);
1204 /* No checks for use-association in public and private statements. */
1207 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1208 const char *name
, locus
* where
)
1211 if (attr
->access
== ACCESS_UNKNOWN
)
1213 attr
->access
= access
;
1214 return check_conflict (attr
, name
, where
);
1218 where
= &gfc_current_locus
;
1219 gfc_error ("ACCESS specification at %L was already specified", where
);
1226 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1227 gfc_formal_arglist
* formal
, locus
* where
)
1230 if (check_used (&sym
->attr
, sym
->name
, where
))
1234 where
= &gfc_current_locus
;
1236 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1237 && sym
->attr
.if_source
!= IFSRC_DECL
)
1239 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1244 sym
->formal
= formal
;
1245 sym
->attr
.if_source
= source
;
1251 /* Add a type to a symbol. */
1254 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1259 where
= &gfc_current_locus
;
1261 if (sym
->ts
.type
!= BT_UNKNOWN
)
1263 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1264 if (!(sym
->ts
.type
== ts
->type
1265 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1266 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1269 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1272 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1273 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1277 flavor
= sym
->attr
.flavor
;
1279 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1280 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1281 && sym
->attr
.subroutine
)
1282 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1284 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1293 /* Clears all attributes. */
1296 gfc_clear_attr (symbol_attribute
* attr
)
1298 memset (attr
, 0, sizeof(symbol_attribute
));
1302 /* Check for missing attributes in the new symbol. Currently does
1303 nothing, but it's not clear that it is unnecessary yet. */
1306 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1307 locus
* where ATTRIBUTE_UNUSED
)
1314 /* Copy an attribute to a symbol attribute, bit by bit. Some
1315 attributes have a lot of side-effects but cannot be present given
1316 where we are called from, so we ignore some bits. */
1319 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1322 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1325 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1327 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1329 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1331 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1333 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1335 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1337 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1339 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1341 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1343 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1345 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1350 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1353 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1356 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1358 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1360 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1363 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1365 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1367 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1369 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1372 if (src
->flavor
!= FL_UNKNOWN
1373 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1376 if (src
->intent
!= INTENT_UNKNOWN
1377 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1380 if (src
->access
!= ACCESS_UNKNOWN
1381 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1384 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1387 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1389 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1392 /* The subroutines that set these bits also cause flavors to be set,
1393 and that has already happened in the original, so don't let it
1398 dest
->intrinsic
= 1;
1407 /************** Component name management ************/
1409 /* Component names of a derived type form their own little namespaces
1410 that are separate from all other spaces. The space is composed of
1411 a singly linked list of gfc_component structures whose head is
1412 located in the parent symbol. */
1415 /* Add a component name to a symbol. The call fails if the name is
1416 already present. On success, the component pointer is modified to
1417 point to the additional component structure. */
1420 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1422 gfc_component
*p
, *tail
;
1426 for (p
= sym
->components
; p
; p
= p
->next
)
1428 if (strcmp (p
->name
, name
) == 0)
1430 gfc_error ("Component '%s' at %C already declared at %L",
1438 /* Allocate a new component. */
1439 p
= gfc_get_component ();
1442 sym
->components
= p
;
1446 p
->name
= gfc_get_string (name
);
1447 p
->loc
= gfc_current_locus
;
1454 /* Recursive function to switch derived types of all symbol in a
1458 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1466 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1467 sym
->ts
.derived
= to
;
1469 switch_types (st
->left
, from
, to
);
1470 switch_types (st
->right
, from
, to
);
1474 /* This subroutine is called when a derived type is used in order to
1475 make the final determination about which version to use. The
1476 standard requires that a type be defined before it is 'used', but
1477 such types can appear in IMPLICIT statements before the actual
1478 definition. 'Using' in this context means declaring a variable to
1479 be that type or using the type constructor.
1481 If a type is used and the components haven't been defined, then we
1482 have to have a derived type in a parent unit. We find the node in
1483 the other namespace and point the symtree node in this namespace to
1484 that node. Further reference to this name point to the correct
1485 node. If we can't find the node in a parent namespace, then we have
1488 This subroutine takes a pointer to a symbol node and returns a
1489 pointer to the translated node or NULL for an error. Usually there
1490 is no translation and we return the node we were passed. */
1493 gfc_use_derived (gfc_symbol
* sym
)
1500 if (sym
->components
!= NULL
)
1501 return sym
; /* Already defined. */
1503 if (sym
->ns
->parent
== NULL
)
1506 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1508 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1512 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1515 /* Get rid of symbol sym, translating all references to s. */
1516 for (i
= 0; i
< GFC_LETTERS
; i
++)
1518 t
= &sym
->ns
->default_type
[i
];
1519 if (t
->derived
== sym
)
1523 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1528 /* Unlink from list of modified symbols. */
1529 gfc_commit_symbol (sym
);
1531 switch_types (sym
->ns
->sym_root
, sym
, s
);
1533 /* TODO: Also have to replace sym -> s in other lists like
1534 namelists, common lists and interface lists. */
1535 gfc_free_symbol (sym
);
1540 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1546 /* Given a derived type node and a component name, try to locate the
1547 component structure. Returns the NULL pointer if the component is
1548 not found or the components are private. */
1551 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1558 sym
= gfc_use_derived (sym
);
1563 for (p
= sym
->components
; p
; p
= p
->next
)
1564 if (strcmp (p
->name
, name
) == 0)
1568 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1572 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1574 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1584 /* Given a symbol, free all of the component structures and everything
1588 free_components (gfc_component
* p
)
1596 gfc_free_array_spec (p
->as
);
1597 gfc_free_expr (p
->initializer
);
1604 /* Set component attributes from a standard symbol attribute
1608 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1611 c
->dimension
= attr
->dimension
;
1612 c
->pointer
= attr
->pointer
;
1613 c
->allocatable
= attr
->allocatable
;
1617 /* Get a standard symbol attribute structure given the component
1621 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1624 gfc_clear_attr (attr
);
1625 attr
->dimension
= c
->dimension
;
1626 attr
->pointer
= c
->pointer
;
1627 attr
->allocatable
= c
->allocatable
;
1631 /******************** Statement label management ********************/
1633 /* Comparison function for statement labels, used for managing the
1637 compare_st_labels (void * a1
, void * b1
)
1639 int a
= ((gfc_st_label
*)a1
)->value
;
1640 int b
= ((gfc_st_label
*)b1
)->value
;
1646 /* Free a single gfc_st_label structure, making sure the tree is not
1647 messed up. This function is called only when some parse error
1651 gfc_free_st_label (gfc_st_label
* label
)
1656 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1658 if (label
->format
!= NULL
)
1659 gfc_free_expr (label
->format
);
1664 /* Free a whole tree of gfc_st_label structures. */
1667 free_st_labels (gfc_st_label
* label
)
1672 free_st_labels (label
->left
);
1673 free_st_labels (label
->right
);
1675 if (label
->format
!= NULL
)
1676 gfc_free_expr (label
->format
);
1681 /* Given a label number, search for and return a pointer to the label
1682 structure, creating it if it does not exist. */
1685 gfc_get_st_label (int labelno
)
1689 /* First see if the label is already in this namespace. */
1690 lp
= gfc_current_ns
->st_labels
;
1693 if (lp
->value
== labelno
)
1696 if (lp
->value
< labelno
)
1702 lp
= gfc_getmem (sizeof (gfc_st_label
));
1704 lp
->value
= labelno
;
1705 lp
->defined
= ST_LABEL_UNKNOWN
;
1706 lp
->referenced
= ST_LABEL_UNKNOWN
;
1708 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1714 /* Called when a statement with a statement label is about to be
1715 accepted. We add the label to the list of the current namespace,
1716 making sure it hasn't been defined previously and referenced
1720 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1724 labelno
= lp
->value
;
1726 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1727 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1728 &lp
->where
, label_locus
);
1731 lp
->where
= *label_locus
;
1735 case ST_LABEL_FORMAT
:
1736 if (lp
->referenced
== ST_LABEL_TARGET
)
1737 gfc_error ("Label %d at %C already referenced as branch target",
1740 lp
->defined
= ST_LABEL_FORMAT
;
1744 case ST_LABEL_TARGET
:
1745 if (lp
->referenced
== ST_LABEL_FORMAT
)
1746 gfc_error ("Label %d at %C already referenced as a format label",
1749 lp
->defined
= ST_LABEL_TARGET
;
1754 lp
->defined
= ST_LABEL_BAD_TARGET
;
1755 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1761 /* Reference a label. Given a label and its type, see if that
1762 reference is consistent with what is known about that label,
1763 updating the unknown state. Returns FAILURE if something goes
1767 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1769 gfc_sl_type label_type
;
1776 labelno
= lp
->value
;
1778 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1779 label_type
= lp
->defined
;
1782 label_type
= lp
->referenced
;
1783 lp
->where
= gfc_current_locus
;
1786 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1788 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1793 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1794 && type
== ST_LABEL_FORMAT
)
1796 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1801 lp
->referenced
= type
;
1809 /************** Symbol table management subroutines ****************/
1811 /* Basic details: Fortran 95 requires a potentially unlimited number
1812 of distinct namespaces when compiling a program unit. This case
1813 occurs during a compilation of internal subprograms because all of
1814 the internal subprograms must be read before we can start
1815 generating code for the host.
1817 Given the tricky nature of the Fortran grammar, we must be able to
1818 undo changes made to a symbol table if the current interpretation
1819 of a statement is found to be incorrect. Whenever a symbol is
1820 looked up, we make a copy of it and link to it. All of these
1821 symbols are kept in a singly linked list so that we can commit or
1822 undo the changes at a later time.
1824 A symtree may point to a symbol node outside of its namespace. In
1825 this case, that symbol has been used as a host associated variable
1826 at some previous time. */
1828 /* Allocate a new namespace structure. Copies the implicit types from
1829 PARENT if PARENT_TYPES is set. */
1832 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1836 gfc_intrinsic_op in
;
1839 ns
= gfc_getmem (sizeof (gfc_namespace
));
1840 ns
->sym_root
= NULL
;
1841 ns
->uop_root
= NULL
;
1842 ns
->default_access
= ACCESS_UNKNOWN
;
1843 ns
->parent
= parent
;
1845 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1846 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1848 /* Initialize default implicit types. */
1849 for (i
= 'a'; i
<= 'z'; i
++)
1851 ns
->set_flag
[i
- 'a'] = 0;
1852 ts
= &ns
->default_type
[i
- 'a'];
1854 if (parent_types
&& ns
->parent
!= NULL
)
1856 /* Copy parent settings */
1857 *ts
= ns
->parent
->default_type
[i
- 'a'];
1861 if (gfc_option
.flag_implicit_none
!= 0)
1867 if ('i' <= i
&& i
<= 'n')
1869 ts
->type
= BT_INTEGER
;
1870 ts
->kind
= gfc_default_integer_kind
;
1875 ts
->kind
= gfc_default_real_kind
;
1885 /* Comparison function for symtree nodes. */
1888 compare_symtree (void * _st1
, void * _st2
)
1890 gfc_symtree
*st1
, *st2
;
1892 st1
= (gfc_symtree
*) _st1
;
1893 st2
= (gfc_symtree
*) _st2
;
1895 return strcmp (st1
->name
, st2
->name
);
1899 /* Allocate a new symtree node and associate it with the new symbol. */
1902 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1906 st
= gfc_getmem (sizeof (gfc_symtree
));
1907 st
->name
= gfc_get_string (name
);
1909 gfc_insert_bbt (root
, st
, compare_symtree
);
1914 /* Delete a symbol from the tree. Does not free the symbol itself! */
1917 delete_symtree (gfc_symtree
** root
, const char *name
)
1919 gfc_symtree st
, *st0
;
1921 st0
= gfc_find_symtree (*root
, name
);
1923 st
.name
= gfc_get_string (name
);
1924 gfc_delete_bbt (root
, &st
, compare_symtree
);
1930 /* Given a root symtree node and a name, try to find the symbol within
1931 the namespace. Returns NULL if the symbol is not found. */
1934 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1940 c
= strcmp (name
, st
->name
);
1944 st
= (c
< 0) ? st
->left
: st
->right
;
1951 /* Given a name find a user operator node, creating it if it doesn't
1952 exist. These are much simpler than symbols because they can't be
1953 ambiguous with one another. */
1956 gfc_get_uop (const char *name
)
1961 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1965 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1967 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1968 uop
->name
= gfc_get_string (name
);
1969 uop
->access
= ACCESS_UNKNOWN
;
1970 uop
->ns
= gfc_current_ns
;
1976 /* Given a name find the user operator node. Returns NULL if it does
1980 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1985 ns
= gfc_current_ns
;
1987 st
= gfc_find_symtree (ns
->uop_root
, name
);
1988 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1992 /* Remove a gfc_symbol structure and everything it points to. */
1995 gfc_free_symbol (gfc_symbol
* sym
)
2001 gfc_free_array_spec (sym
->as
);
2003 free_components (sym
->components
);
2005 gfc_free_expr (sym
->value
);
2007 gfc_free_namelist (sym
->namelist
);
2009 gfc_free_namespace (sym
->formal_ns
);
2011 if (!sym
->attr
.generic_copy
)
2012 gfc_free_interface (sym
->generic
);
2014 gfc_free_formal_arglist (sym
->formal
);
2020 /* Allocate and initialize a new symbol node. */
2023 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2027 p
= gfc_getmem (sizeof (gfc_symbol
));
2029 gfc_clear_ts (&p
->ts
);
2030 gfc_clear_attr (&p
->attr
);
2033 p
->declared_at
= gfc_current_locus
;
2035 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2036 gfc_internal_error ("new_symbol(): Symbol name too long");
2038 p
->name
= gfc_get_string (name
);
2043 /* Generate an error if a symbol is ambiguous. */
2046 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2049 if (st
->n
.sym
->module
)
2050 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2051 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2053 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2054 "from current program unit", name
, st
->n
.sym
->name
);
2058 /* Search for a symtree starting in the current namespace, resorting to
2059 any parent namespaces if requested by a nonzero parent_flag.
2060 Returns nonzero if the name is ambiguous. */
2063 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2064 gfc_symtree
** result
)
2069 ns
= gfc_current_ns
;
2073 st
= gfc_find_symtree (ns
->sym_root
, name
);
2077 /* Ambiguous generic interfaces are permitted, as long
2078 as the specific interfaces are different. */
2079 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2081 ambiguous_symbol (name
, st
);
2100 /* Same, but returns the symbol instead. */
2103 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2104 gfc_symbol
** result
)
2109 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2114 *result
= st
->n
.sym
;
2120 /* Save symbol with the information necessary to back it out. */
2123 save_symbol_data (gfc_symbol
* sym
)
2126 if (sym
->new || sym
->old_symbol
!= NULL
)
2129 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2130 *(sym
->old_symbol
) = *sym
;
2132 sym
->tlink
= changed_syms
;
2137 /* Given a name, find a symbol, or create it if it does not exist yet
2138 in the current namespace. If the symbol is found we make sure that
2141 The integer return code indicates
2143 1 The symbol name was ambiguous
2144 2 The name meant to be established was already host associated.
2146 So if the return value is nonzero, then an error was issued. */
2149 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2154 /* This doesn't usually happen during resolution. */
2156 ns
= gfc_current_ns
;
2158 /* Try to find the symbol in ns. */
2159 st
= gfc_find_symtree (ns
->sym_root
, name
);
2163 /* If not there, create a new symbol. */
2164 p
= gfc_new_symbol (name
, ns
);
2166 /* Add to the list of tentative symbols. */
2167 p
->old_symbol
= NULL
;
2168 p
->tlink
= changed_syms
;
2173 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2180 /* Make sure the existing symbol is OK. Ambiguous
2181 generic interfaces are permitted, as long as the
2182 specific interfaces are different. */
2183 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2185 ambiguous_symbol (name
, st
);
2191 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2193 /* Symbol is from another namespace. */
2194 gfc_error ("Symbol '%s' at %C has already been host associated",
2201 /* Copy in case this symbol is changed. */
2202 save_symbol_data (p
);
2211 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2217 i
= gfc_get_sym_tree (name
, ns
, &st
);
2222 *result
= st
->n
.sym
;
2229 /* Subroutine that searches for a symbol, creating it if it doesn't
2230 exist, but tries to host-associate the symbol if possible. */
2233 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2238 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2241 save_symbol_data (st
->n
.sym
);
2247 if (gfc_current_ns
->parent
!= NULL
)
2249 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2260 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2265 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2270 i
= gfc_get_ha_sym_tree (name
, &st
);
2273 *result
= st
->n
.sym
;
2280 /* Return true if both symbols could refer to the same data object. Does
2281 not take account of aliasing due to equivalence statements. */
2284 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2286 /* Aliasing isn't possible if the symbols have different base types. */
2287 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2290 /* Pointers can point to other pointers, target objects and allocatable
2291 objects. Two allocatable objects cannot share the same storage. */
2292 if (lsym
->attr
.pointer
2293 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2295 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2297 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2304 /* Undoes all the changes made to symbols in the current statement.
2305 This subroutine is made simpler due to the fact that attributes are
2306 never removed once added. */
2309 gfc_undo_symbols (void)
2311 gfc_symbol
*p
, *q
, *old
;
2313 for (p
= changed_syms
; p
; p
= q
)
2319 /* Symbol was new. */
2320 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2324 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2326 gfc_free_symbol (p
);
2330 /* Restore previous state of symbol. Just copy simple stuff. */
2332 old
= p
->old_symbol
;
2334 p
->ts
.type
= old
->ts
.type
;
2335 p
->ts
.kind
= old
->ts
.kind
;
2337 p
->attr
= old
->attr
;
2339 if (p
->value
!= old
->value
)
2341 gfc_free_expr (old
->value
);
2345 if (p
->as
!= old
->as
)
2348 gfc_free_array_spec (p
->as
);
2352 p
->generic
= old
->generic
;
2353 p
->component_access
= old
->component_access
;
2355 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2357 gfc_free_namelist (p
->namelist
);
2363 if (p
->namelist_tail
!= old
->namelist_tail
)
2365 gfc_free_namelist (old
->namelist_tail
);
2366 old
->namelist_tail
->next
= NULL
;
2370 p
->namelist_tail
= old
->namelist_tail
;
2372 if (p
->formal
!= old
->formal
)
2374 gfc_free_formal_arglist (p
->formal
);
2375 p
->formal
= old
->formal
;
2378 gfc_free (p
->old_symbol
);
2379 p
->old_symbol
= NULL
;
2383 changed_syms
= NULL
;
2387 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2388 components of old_symbol that might need deallocation are the "allocatables"
2389 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2390 namelist_tail. In case these differ between old_symbol and sym, it's just
2391 because sym->namelist has gotten a few more items. */
2394 free_old_symbol (gfc_symbol
* sym
)
2396 if (sym
->old_symbol
== NULL
)
2399 if (sym
->old_symbol
->as
!= sym
->as
)
2400 gfc_free_array_spec (sym
->old_symbol
->as
);
2402 if (sym
->old_symbol
->value
!= sym
->value
)
2403 gfc_free_expr (sym
->old_symbol
->value
);
2405 if (sym
->old_symbol
->formal
!= sym
->formal
)
2406 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2408 gfc_free (sym
->old_symbol
);
2409 sym
->old_symbol
= NULL
;
2413 /* Makes the changes made in the current statement permanent-- gets
2414 rid of undo information. */
2417 gfc_commit_symbols (void)
2421 for (p
= changed_syms
; p
; p
= q
)
2428 free_old_symbol (p
);
2430 changed_syms
= NULL
;
2434 /* Makes the changes made in one symbol permanent -- gets rid of undo
2438 gfc_commit_symbol (gfc_symbol
* sym
)
2442 if (changed_syms
== sym
)
2443 changed_syms
= sym
->tlink
;
2446 for (p
= changed_syms
; p
; p
= p
->tlink
)
2447 if (p
->tlink
== sym
)
2449 p
->tlink
= sym
->tlink
;
2458 free_old_symbol (sym
);
2462 /* Recursive function that deletes an entire tree and all the common
2463 head structures it points to. */
2466 free_common_tree (gfc_symtree
* common_tree
)
2468 if (common_tree
== NULL
)
2471 free_common_tree (common_tree
->left
);
2472 free_common_tree (common_tree
->right
);
2474 gfc_free (common_tree
);
2478 /* Recursive function that deletes an entire tree and all the user
2479 operator nodes that it contains. */
2482 free_uop_tree (gfc_symtree
* uop_tree
)
2485 if (uop_tree
== NULL
)
2488 free_uop_tree (uop_tree
->left
);
2489 free_uop_tree (uop_tree
->right
);
2491 gfc_free_interface (uop_tree
->n
.uop
->operator);
2493 gfc_free (uop_tree
->n
.uop
);
2494 gfc_free (uop_tree
);
2498 /* Recursive function that deletes an entire tree and all the symbols
2499 that it contains. */
2502 free_sym_tree (gfc_symtree
* sym_tree
)
2507 if (sym_tree
== NULL
)
2510 free_sym_tree (sym_tree
->left
);
2511 free_sym_tree (sym_tree
->right
);
2513 sym
= sym_tree
->n
.sym
;
2517 gfc_internal_error ("free_sym_tree(): Negative refs");
2519 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2521 /* As formal_ns contains a reference to sym, delete formal_ns just
2522 before the deletion of sym. */
2523 ns
= sym
->formal_ns
;
2524 sym
->formal_ns
= NULL
;
2525 gfc_free_namespace (ns
);
2527 else if (sym
->refs
== 0)
2529 /* Go ahead and delete the symbol. */
2530 gfc_free_symbol (sym
);
2533 gfc_free (sym_tree
);
2537 /* Free a derived type list. */
2540 gfc_free_dt_list (gfc_dt_list
* dt
)
2552 /* Free the gfc_equiv_info's. */
2555 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2559 gfc_free_equiv_infos (s
->next
);
2564 /* Free the gfc_equiv_lists. */
2567 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2571 gfc_free_equiv_lists (l
->next
);
2572 gfc_free_equiv_infos (l
->equiv
);
2577 /* Free a namespace structure and everything below it. Interface
2578 lists associated with intrinsic operators are not freed. These are
2579 taken care of when a specific name is freed. */
2582 gfc_free_namespace (gfc_namespace
* ns
)
2584 gfc_charlen
*cl
, *cl2
;
2585 gfc_namespace
*p
, *q
;
2594 gcc_assert (ns
->refs
== 0);
2596 gfc_free_statements (ns
->code
);
2598 free_sym_tree (ns
->sym_root
);
2599 free_uop_tree (ns
->uop_root
);
2600 free_common_tree (ns
->common_root
);
2602 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2605 gfc_free_expr (cl
->length
);
2609 free_st_labels (ns
->st_labels
);
2611 gfc_free_equiv (ns
->equiv
);
2612 gfc_free_equiv_lists (ns
->equiv_lists
);
2614 gfc_free_dt_list (ns
->derived_types
);
2616 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2617 gfc_free_interface (ns
->operator[i
]);
2619 gfc_free_data (ns
->data
);
2623 /* Recursively free any contained namespaces. */
2629 gfc_free_namespace (q
);
2635 gfc_symbol_init_2 (void)
2638 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2643 gfc_symbol_done_2 (void)
2646 gfc_free_namespace (gfc_current_ns
);
2647 gfc_current_ns
= NULL
;
2651 /* Clear mark bits from symbol nodes associated with a symtree node. */
2654 clear_sym_mark (gfc_symtree
* st
)
2657 st
->n
.sym
->mark
= 0;
2661 /* Recursively traverse the symtree nodes. */
2664 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2670 gfc_traverse_symtree (st
->left
, func
);
2671 gfc_traverse_symtree (st
->right
, func
);
2676 /* Recursive namespace traversal function. */
2679 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2685 if (st
->n
.sym
->mark
== 0)
2686 (*func
) (st
->n
.sym
);
2687 st
->n
.sym
->mark
= 1;
2689 traverse_ns (st
->left
, func
);
2690 traverse_ns (st
->right
, func
);
2694 /* Call a given function for all symbols in the namespace. We take
2695 care that each gfc_symbol node is called exactly once. */
2698 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2701 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2703 traverse_ns (ns
->sym_root
, func
);
2707 /* Return TRUE if the symbol is an automatic variable. */
2709 gfc_is_var_automatic (gfc_symbol
* sym
)
2711 /* Pointer and allocatable variables are never automatic. */
2712 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2714 /* Check for arrays with non-constant size. */
2715 if (sym
->attr
.dimension
&& sym
->as
2716 && !gfc_is_compile_time_shape (sym
->as
))
2718 /* Check for non-constant length character variables. */
2719 if (sym
->ts
.type
== BT_CHARACTER
2721 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2726 /* Given a symbol, mark it as SAVEd if it is allowed. */
2729 save_symbol (gfc_symbol
* sym
)
2732 if (sym
->attr
.use_assoc
)
2735 if (sym
->attr
.in_common
2737 || sym
->attr
.flavor
!= FL_VARIABLE
)
2739 /* Automatic objects are not saved. */
2740 if (gfc_is_var_automatic (sym
))
2742 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2746 /* Mark those symbols which can be SAVEd as such. */
2749 gfc_save_all (gfc_namespace
* ns
)
2752 gfc_traverse_ns (ns
, save_symbol
);
2757 /* Make sure that no changes to symbols are pending. */
2760 gfc_symbol_state(void) {
2762 if (changed_syms
!= NULL
)
2763 gfc_internal_error("Symbol changes still pending!");
2768 /************** Global symbol handling ************/
2771 /* Search a tree for the global symbol. */
2774 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2780 if (strcmp (symbol
->name
, name
) == 0)
2783 s
= gfc_find_gsymbol (symbol
->left
, name
);
2787 s
= gfc_find_gsymbol (symbol
->right
, name
);
2795 /* Compare two global symbols. Used for managing the BB tree. */
2798 gsym_compare (void * _s1
, void * _s2
)
2800 gfc_gsymbol
*s1
, *s2
;
2802 s1
= (gfc_gsymbol
*)_s1
;
2803 s2
= (gfc_gsymbol
*)_s2
;
2804 return strcmp(s1
->name
, s2
->name
);
2808 /* Get a global symbol, creating it if it doesn't exist. */
2811 gfc_get_gsymbol (const char *name
)
2815 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2819 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2820 s
->type
= GSYM_UNKNOWN
;
2821 s
->name
= gfc_get_string (name
);
2823 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);