1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
94 gfc_dt_list
*gfc_derived_types
;
97 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
99 /* The following static variable indicates whether a particular element has
100 been explicitly set or not. */
102 static int new_flag
[GFC_LETTERS
];
105 /* Handle a correctly parsed IMPLICIT NONE. */
108 gfc_set_implicit_none (void)
112 if (gfc_current_ns
->seen_implicit_none
)
114 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
118 gfc_current_ns
->seen_implicit_none
= 1;
120 for (i
= 0; i
< GFC_LETTERS
; i
++)
122 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
123 gfc_current_ns
->set_flag
[i
] = 1;
128 /* Reset the implicit range flags. */
131 gfc_clear_new_implicit (void)
135 for (i
= 0; i
< GFC_LETTERS
; i
++)
140 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
143 gfc_add_new_implicit_range (int c1
, int c2
)
150 for (i
= c1
; i
<= c2
; i
++)
154 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
166 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
167 the new implicit types back into the existing types will work. */
170 gfc_merge_new_implicit (gfc_typespec
* ts
)
174 if (gfc_current_ns
->seen_implicit_none
)
176 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
180 for (i
= 0; i
< GFC_LETTERS
; i
++)
185 if (gfc_current_ns
->set_flag
[i
])
187 gfc_error ("Letter %c already has an IMPLICIT type at %C",
191 gfc_current_ns
->default_type
[i
] = *ts
;
192 gfc_current_ns
->set_flag
[i
] = 1;
199 /* Given a symbol, return a pointer to the typespec for its default type. */
202 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
206 letter
= sym
->name
[0];
208 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
209 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
210 "gfortran developers, and should not be used for "
211 "implicitly typed variables");
213 if (letter
< 'a' || letter
> 'z')
214 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
219 return &ns
->default_type
[letter
- 'a'];
223 /* Given a pointer to a symbol, set its type according to the first
224 letter of its name. Fails if the letter in question has no default
228 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
232 if (sym
->ts
.type
!= BT_UNKNOWN
)
233 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
235 ts
= gfc_get_default_type (sym
, ns
);
237 if (ts
->type
== BT_UNKNOWN
)
239 if (error_flag
&& !sym
->attr
.untyped
)
241 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
242 sym
->name
, &sym
->declared_at
);
243 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
250 sym
->attr
.implicit_type
= 1;
256 /* This function is called from parse.c(parse_progunit) to check the
257 type of the function is not implicitly typed in the host namespace
258 and to implicitly type the function result, if necessary. */
261 gfc_check_function_type (gfc_namespace
*ns
)
263 gfc_symbol
*proc
= ns
->proc_name
;
265 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
268 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
270 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
273 if (proc
->result
!= proc
)
274 proc
->ts
= proc
->result
->ts
;
278 gfc_error ("unable to implicitly type the function result "
279 "'%s' at %L", proc
->result
->name
,
280 &proc
->result
->declared_at
);
281 proc
->result
->attr
.untyped
= 1;
287 /******************** Symbol attribute stuff *********************/
289 /* This is a generic conflict-checker. We do this to avoid having a
290 single conflict in two places. */
292 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
293 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
294 #define conf_std(a, b, std) if (attr->a && attr->b)\
303 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
305 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
306 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
307 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
308 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
309 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
310 *private = "PRIVATE", *recursive
= "RECURSIVE",
311 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
312 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
313 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
314 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
315 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
316 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
317 *volatile_
= "VOLATILE", *protected = "PROTECTED";
318 static const char *threadprivate
= "THREADPRIVATE";
324 where
= &gfc_current_locus
;
326 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
330 standard
= GFC_STD_F2003
;
334 /* Check for attributes not allowed in a BLOCK DATA. */
335 if (gfc_current_state () == COMP_BLOCK_DATA
)
339 if (attr
->in_namelist
)
341 if (attr
->allocatable
)
347 if (attr
->access
== ACCESS_PRIVATE
)
349 if (attr
->access
== ACCESS_PUBLIC
)
351 if (attr
->intent
!= INTENT_UNKNOWN
)
357 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
364 conf (dummy
, intrinsic
);
366 conf (dummy
, threadprivate
);
367 conf (pointer
, target
);
368 conf (pointer
, external
);
369 conf (pointer
, intrinsic
);
370 conf (pointer
, elemental
);
371 conf (allocatable
, elemental
);
373 conf (target
, external
);
374 conf (target
, intrinsic
);
375 conf (external
, dimension
); /* See Fortran 95's R504. */
377 conf (external
, intrinsic
);
379 if (attr
->if_source
|| attr
->contained
)
381 conf (external
, subroutine
);
382 conf (external
, function
);
385 conf (allocatable
, pointer
);
386 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
387 conf_std (allocatable
, function
, GFC_STD_F2003
);
388 conf_std (allocatable
, result
, GFC_STD_F2003
);
389 conf (elemental
, recursive
);
391 conf (in_common
, dummy
);
392 conf (in_common
, allocatable
);
393 conf (in_common
, result
);
394 conf (in_common
, save
);
397 conf (dummy
, result
);
399 conf (in_equivalence
, use_assoc
);
400 conf (in_equivalence
, dummy
);
401 conf (in_equivalence
, target
);
402 conf (in_equivalence
, pointer
);
403 conf (in_equivalence
, function
);
404 conf (in_equivalence
, result
);
405 conf (in_equivalence
, entry
);
406 conf (in_equivalence
, allocatable
);
407 conf (in_equivalence
, threadprivate
);
409 conf (in_namelist
, pointer
);
410 conf (in_namelist
, allocatable
);
412 conf (entry
, result
);
414 conf (function
, subroutine
);
416 /* Cray pointer/pointee conflicts. */
417 conf (cray_pointer
, cray_pointee
);
418 conf (cray_pointer
, dimension
);
419 conf (cray_pointer
, pointer
);
420 conf (cray_pointer
, target
);
421 conf (cray_pointer
, allocatable
);
422 conf (cray_pointer
, external
);
423 conf (cray_pointer
, intrinsic
);
424 conf (cray_pointer
, in_namelist
);
425 conf (cray_pointer
, function
);
426 conf (cray_pointer
, subroutine
);
427 conf (cray_pointer
, entry
);
429 conf (cray_pointee
, allocatable
);
430 conf (cray_pointee
, intent
);
431 conf (cray_pointee
, optional
);
432 conf (cray_pointee
, dummy
);
433 conf (cray_pointee
, target
);
434 conf (cray_pointee
, intrinsic
);
435 conf (cray_pointee
, pointer
);
436 conf (cray_pointee
, entry
);
437 conf (cray_pointee
, in_common
);
438 conf (cray_pointee
, in_equivalence
);
439 conf (cray_pointee
, threadprivate
);
442 conf (data
, function
);
444 conf (data
, allocatable
);
445 conf (data
, use_assoc
);
447 conf (protected, intrinsic
)
448 conf (protected, external
)
449 conf (protected, in_common
)
451 conf (value
, pointer
)
452 conf (value
, allocatable
)
453 conf (value
, subroutine
)
454 conf (value
, function
)
455 conf (value
, volatile_
)
456 conf (value
, dimension
)
457 conf (value
, external
)
459 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
462 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
466 conf (volatile_
, intrinsic
)
467 conf (volatile_
, external
)
469 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
476 a1
= gfc_code2string (flavors
, attr
->flavor
);
478 if (attr
->in_namelist
479 && attr
->flavor
!= FL_VARIABLE
480 && attr
->flavor
!= FL_PROCEDURE
481 && attr
->flavor
!= FL_UNKNOWN
)
488 switch (attr
->flavor
)
509 conf2 (threadprivate
);
520 if (attr
->subroutine
)
529 conf2(threadprivate
);
534 case PROC_ST_FUNCTION
:
547 conf2 (threadprivate
);
568 conf2 (threadprivate
);
570 if (attr
->intent
!= INTENT_UNKNOWN
)
593 conf2 (threadprivate
);
604 gfc_error ("%s attribute conflicts with %s attribute at %L",
607 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
608 a1
, a2
, name
, where
);
615 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
616 "with %s attribute at %L", a1
, a2
,
621 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
622 "with %s attribute in '%s' at %L",
623 a1
, a2
, name
, where
);
632 /* Mark a symbol as referenced. */
635 gfc_set_sym_referenced (gfc_symbol
* sym
)
637 if (sym
->attr
.referenced
)
640 sym
->attr
.referenced
= 1;
642 /* Remember which order dummy variables are accessed in. */
644 sym
->dummy_order
= next_dummy_order
++;
648 /* Common subroutine called by attribute changing subroutines in order
649 to prevent them from changing a symbol that has been
650 use-associated. Returns zero if it is OK to change the symbol,
654 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
657 if (attr
->use_assoc
== 0)
661 where
= &gfc_current_locus
;
664 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
667 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
674 /* Generate an error because of a duplicate attribute. */
677 duplicate_attr (const char *attr
, locus
* where
)
681 where
= &gfc_current_locus
;
683 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
686 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
689 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
691 if (check_used (attr
, NULL
, where
))
694 return check_conflict (attr
, NULL
, where
);
698 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
701 if (check_used (attr
, NULL
, where
))
704 if (attr
->allocatable
)
706 duplicate_attr ("ALLOCATABLE", where
);
710 attr
->allocatable
= 1;
711 return check_conflict (attr
, NULL
, where
);
716 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
719 if (check_used (attr
, name
, where
))
724 duplicate_attr ("DIMENSION", where
);
729 return check_conflict (attr
, name
, where
);
734 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
737 if (check_used (attr
, NULL
, where
))
742 duplicate_attr ("EXTERNAL", where
);
748 return check_conflict (attr
, NULL
, where
);
753 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
756 if (check_used (attr
, NULL
, where
))
761 duplicate_attr ("INTRINSIC", where
);
767 return check_conflict (attr
, NULL
, where
);
772 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
775 if (check_used (attr
, NULL
, where
))
780 duplicate_attr ("OPTIONAL", where
);
785 return check_conflict (attr
, NULL
, where
);
790 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
793 if (check_used (attr
, NULL
, where
))
797 return check_conflict (attr
, NULL
, where
);
802 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
805 if (check_used (attr
, NULL
, where
))
808 attr
->cray_pointer
= 1;
809 return check_conflict (attr
, NULL
, where
);
814 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
817 if (check_used (attr
, NULL
, where
))
820 if (attr
->cray_pointee
)
822 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
823 " statements", where
);
827 attr
->cray_pointee
= 1;
828 return check_conflict (attr
, NULL
, where
);
832 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
834 if (check_used (attr
, name
, where
))
839 if (gfc_notify_std (GFC_STD_LEGACY
,
840 "Duplicate PROTECTED attribute specified at %L",
847 return check_conflict (attr
, name
, where
);
851 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
854 if (check_used (attr
, name
, where
))
858 return check_conflict (attr
, name
, where
);
863 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
866 if (check_used (attr
, name
, where
))
872 ("SAVE attribute at %L cannot be specified in a PURE procedure",
879 if (gfc_notify_std (GFC_STD_LEGACY
,
880 "Duplicate SAVE attribute specified at %L",
887 return check_conflict (attr
, name
, where
);
891 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
894 if (check_used (attr
, name
, where
))
899 if (gfc_notify_std (GFC_STD_LEGACY
,
900 "Duplicate VALUE attribute specified at %L",
907 return check_conflict (attr
, name
, where
);
911 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
913 /* No check_used needed as 11.2.1 of the F2003 standard allows
914 that the local identifier made accessible by a use statement can be
915 given a VOLATILE attribute. */
917 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
918 if (gfc_notify_std (GFC_STD_LEGACY
,
919 "Duplicate VOLATILE attribute specified at %L", where
)
924 attr
->volatile_ns
= gfc_current_ns
;
925 return check_conflict (attr
, name
, where
);
930 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
932 if (check_used (attr
, name
, where
))
935 if (attr
->threadprivate
)
937 duplicate_attr ("THREADPRIVATE", where
);
941 attr
->threadprivate
= 1;
942 return check_conflict (attr
, name
, where
);
947 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
950 if (check_used (attr
, NULL
, where
))
955 duplicate_attr ("TARGET", where
);
960 return check_conflict (attr
, NULL
, where
);
965 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
968 if (check_used (attr
, name
, where
))
971 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
973 return check_conflict (attr
, name
, where
);
978 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
981 if (check_used (attr
, name
, where
))
984 /* Duplicate attribute already checked for. */
986 if (check_conflict (attr
, name
, where
) == FAILURE
)
989 if (attr
->flavor
== FL_VARIABLE
)
992 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
996 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
999 /* Duplicate attribute already checked for. */
1000 attr
->in_equivalence
= 1;
1001 if (check_conflict (attr
, name
, where
) == FAILURE
)
1004 if (attr
->flavor
== FL_VARIABLE
)
1007 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1012 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1015 if (check_used (attr
, name
, where
))
1019 return check_conflict (attr
, name
, where
);
1024 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
1028 attr
->in_namelist
= 1;
1029 return check_conflict (attr
, name
, where
);
1034 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
1037 if (check_used (attr
, name
, where
))
1041 return check_conflict (attr
, name
, where
);
1046 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1049 if (check_used (attr
, NULL
, where
))
1052 attr
->elemental
= 1;
1053 return check_conflict (attr
, NULL
, where
);
1058 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1061 if (check_used (attr
, NULL
, where
))
1065 return check_conflict (attr
, NULL
, where
);
1070 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1073 if (check_used (attr
, NULL
, where
))
1076 attr
->recursive
= 1;
1077 return check_conflict (attr
, NULL
, where
);
1082 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1085 if (check_used (attr
, name
, where
))
1090 duplicate_attr ("ENTRY", where
);
1095 return check_conflict (attr
, name
, where
);
1100 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1103 if (attr
->flavor
!= FL_PROCEDURE
1104 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1108 return check_conflict (attr
, name
, where
);
1113 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1116 if (attr
->flavor
!= FL_PROCEDURE
1117 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1120 attr
->subroutine
= 1;
1121 return check_conflict (attr
, name
, where
);
1126 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1129 if (attr
->flavor
!= FL_PROCEDURE
1130 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1134 return check_conflict (attr
, name
, where
);
1138 /* Flavors are special because some flavors are not what Fortran
1139 considers attributes and can be reaffirmed multiple times. */
1142 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1146 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1147 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1148 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1151 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1154 if (attr
->flavor
!= FL_UNKNOWN
)
1157 where
= &gfc_current_locus
;
1159 gfc_error ("%s attribute conflicts with %s attribute at %L",
1160 gfc_code2string (flavors
, attr
->flavor
),
1161 gfc_code2string (flavors
, f
), where
);
1168 return check_conflict (attr
, name
, where
);
1173 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1174 const char *name
, locus
* where
)
1177 if (check_used (attr
, name
, where
))
1180 if (attr
->flavor
!= FL_PROCEDURE
1181 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1185 where
= &gfc_current_locus
;
1187 if (attr
->proc
!= PROC_UNKNOWN
)
1189 gfc_error ("%s procedure at %L is already declared as %s procedure",
1190 gfc_code2string (procedures
, t
), where
,
1191 gfc_code2string (procedures
, attr
->proc
));
1198 /* Statement functions are always scalar and functions. */
1199 if (t
== PROC_ST_FUNCTION
1200 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1201 || attr
->dimension
))
1204 return check_conflict (attr
, name
, where
);
1209 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1212 if (check_used (attr
, NULL
, where
))
1215 if (attr
->intent
== INTENT_UNKNOWN
)
1217 attr
->intent
= intent
;
1218 return check_conflict (attr
, NULL
, where
);
1222 where
= &gfc_current_locus
;
1224 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1225 gfc_intent_string (attr
->intent
),
1226 gfc_intent_string (intent
), where
);
1232 /* No checks for use-association in public and private statements. */
1235 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1236 const char *name
, locus
* where
)
1239 if (attr
->access
== ACCESS_UNKNOWN
)
1241 attr
->access
= access
;
1242 return check_conflict (attr
, name
, where
);
1246 where
= &gfc_current_locus
;
1247 gfc_error ("ACCESS specification at %L was already specified", where
);
1254 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1255 gfc_formal_arglist
* formal
, locus
* where
)
1258 if (check_used (&sym
->attr
, sym
->name
, where
))
1262 where
= &gfc_current_locus
;
1264 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1265 && sym
->attr
.if_source
!= IFSRC_DECL
)
1267 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1272 sym
->formal
= formal
;
1273 sym
->attr
.if_source
= source
;
1279 /* Add a type to a symbol. */
1282 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1287 where
= &gfc_current_locus
;
1289 if (sym
->ts
.type
!= BT_UNKNOWN
)
1291 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1292 if (!(sym
->ts
.type
== ts
->type
1293 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1294 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1297 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1300 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1301 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1305 flavor
= sym
->attr
.flavor
;
1307 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1308 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1309 && sym
->attr
.subroutine
)
1310 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1312 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1321 /* Clears all attributes. */
1324 gfc_clear_attr (symbol_attribute
* attr
)
1326 memset (attr
, 0, sizeof(symbol_attribute
));
1330 /* Check for missing attributes in the new symbol. Currently does
1331 nothing, but it's not clear that it is unnecessary yet. */
1334 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1335 locus
* where ATTRIBUTE_UNUSED
)
1342 /* Copy an attribute to a symbol attribute, bit by bit. Some
1343 attributes have a lot of side-effects but cannot be present given
1344 where we are called from, so we ignore some bits. */
1347 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1350 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1353 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1355 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1357 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1359 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1361 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1363 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1365 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1367 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1369 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1371 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1373 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1378 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1381 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1384 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1386 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1388 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1391 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1393 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1395 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1397 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1400 if (src
->flavor
!= FL_UNKNOWN
1401 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1404 if (src
->intent
!= INTENT_UNKNOWN
1405 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1408 if (src
->access
!= ACCESS_UNKNOWN
1409 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1412 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1415 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1417 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1420 /* The subroutines that set these bits also cause flavors to be set,
1421 and that has already happened in the original, so don't let it
1426 dest
->intrinsic
= 1;
1435 /************** Component name management ************/
1437 /* Component names of a derived type form their own little namespaces
1438 that are separate from all other spaces. The space is composed of
1439 a singly linked list of gfc_component structures whose head is
1440 located in the parent symbol. */
1443 /* Add a component name to a symbol. The call fails if the name is
1444 already present. On success, the component pointer is modified to
1445 point to the additional component structure. */
1448 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1450 gfc_component
*p
, *tail
;
1454 for (p
= sym
->components
; p
; p
= p
->next
)
1456 if (strcmp (p
->name
, name
) == 0)
1458 gfc_error ("Component '%s' at %C already declared at %L",
1466 /* Allocate a new component. */
1467 p
= gfc_get_component ();
1470 sym
->components
= p
;
1474 p
->name
= gfc_get_string (name
);
1475 p
->loc
= gfc_current_locus
;
1482 /* Recursive function to switch derived types of all symbol in a
1486 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1494 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1495 sym
->ts
.derived
= to
;
1497 switch_types (st
->left
, from
, to
);
1498 switch_types (st
->right
, from
, to
);
1502 /* This subroutine is called when a derived type is used in order to
1503 make the final determination about which version to use. The
1504 standard requires that a type be defined before it is 'used', but
1505 such types can appear in IMPLICIT statements before the actual
1506 definition. 'Using' in this context means declaring a variable to
1507 be that type or using the type constructor.
1509 If a type is used and the components haven't been defined, then we
1510 have to have a derived type in a parent unit. We find the node in
1511 the other namespace and point the symtree node in this namespace to
1512 that node. Further reference to this name point to the correct
1513 node. If we can't find the node in a parent namespace, then we have
1516 This subroutine takes a pointer to a symbol node and returns a
1517 pointer to the translated node or NULL for an error. Usually there
1518 is no translation and we return the node we were passed. */
1521 gfc_use_derived (gfc_symbol
* sym
)
1528 if (sym
->components
!= NULL
)
1529 return sym
; /* Already defined. */
1531 if (sym
->ns
->parent
== NULL
)
1534 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1536 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1540 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1543 /* Get rid of symbol sym, translating all references to s. */
1544 for (i
= 0; i
< GFC_LETTERS
; i
++)
1546 t
= &sym
->ns
->default_type
[i
];
1547 if (t
->derived
== sym
)
1551 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1556 /* Unlink from list of modified symbols. */
1557 gfc_commit_symbol (sym
);
1559 switch_types (sym
->ns
->sym_root
, sym
, s
);
1561 /* TODO: Also have to replace sym -> s in other lists like
1562 namelists, common lists and interface lists. */
1563 gfc_free_symbol (sym
);
1568 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1574 /* Given a derived type node and a component name, try to locate the
1575 component structure. Returns the NULL pointer if the component is
1576 not found or the components are private. */
1579 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1586 sym
= gfc_use_derived (sym
);
1591 for (p
= sym
->components
; p
; p
= p
->next
)
1592 if (strcmp (p
->name
, name
) == 0)
1596 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1600 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1602 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1612 /* Given a symbol, free all of the component structures and everything
1616 free_components (gfc_component
* p
)
1624 gfc_free_array_spec (p
->as
);
1625 gfc_free_expr (p
->initializer
);
1632 /* Set component attributes from a standard symbol attribute
1636 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1639 c
->dimension
= attr
->dimension
;
1640 c
->pointer
= attr
->pointer
;
1641 c
->allocatable
= attr
->allocatable
;
1645 /* Get a standard symbol attribute structure given the component
1649 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1652 gfc_clear_attr (attr
);
1653 attr
->dimension
= c
->dimension
;
1654 attr
->pointer
= c
->pointer
;
1655 attr
->allocatable
= c
->allocatable
;
1659 /******************** Statement label management ********************/
1661 /* Comparison function for statement labels, used for managing the
1665 compare_st_labels (void * a1
, void * b1
)
1667 int a
= ((gfc_st_label
*)a1
)->value
;
1668 int b
= ((gfc_st_label
*)b1
)->value
;
1674 /* Free a single gfc_st_label structure, making sure the tree is not
1675 messed up. This function is called only when some parse error
1679 gfc_free_st_label (gfc_st_label
* label
)
1684 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1686 if (label
->format
!= NULL
)
1687 gfc_free_expr (label
->format
);
1692 /* Free a whole tree of gfc_st_label structures. */
1695 free_st_labels (gfc_st_label
* label
)
1700 free_st_labels (label
->left
);
1701 free_st_labels (label
->right
);
1703 if (label
->format
!= NULL
)
1704 gfc_free_expr (label
->format
);
1709 /* Given a label number, search for and return a pointer to the label
1710 structure, creating it if it does not exist. */
1713 gfc_get_st_label (int labelno
)
1717 /* First see if the label is already in this namespace. */
1718 lp
= gfc_current_ns
->st_labels
;
1721 if (lp
->value
== labelno
)
1724 if (lp
->value
< labelno
)
1730 lp
= gfc_getmem (sizeof (gfc_st_label
));
1732 lp
->value
= labelno
;
1733 lp
->defined
= ST_LABEL_UNKNOWN
;
1734 lp
->referenced
= ST_LABEL_UNKNOWN
;
1736 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1742 /* Called when a statement with a statement label is about to be
1743 accepted. We add the label to the list of the current namespace,
1744 making sure it hasn't been defined previously and referenced
1748 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1752 labelno
= lp
->value
;
1754 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1755 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1756 &lp
->where
, label_locus
);
1759 lp
->where
= *label_locus
;
1763 case ST_LABEL_FORMAT
:
1764 if (lp
->referenced
== ST_LABEL_TARGET
)
1765 gfc_error ("Label %d at %C already referenced as branch target",
1768 lp
->defined
= ST_LABEL_FORMAT
;
1772 case ST_LABEL_TARGET
:
1773 if (lp
->referenced
== ST_LABEL_FORMAT
)
1774 gfc_error ("Label %d at %C already referenced as a format label",
1777 lp
->defined
= ST_LABEL_TARGET
;
1782 lp
->defined
= ST_LABEL_BAD_TARGET
;
1783 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1789 /* Reference a label. Given a label and its type, see if that
1790 reference is consistent with what is known about that label,
1791 updating the unknown state. Returns FAILURE if something goes
1795 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1797 gfc_sl_type label_type
;
1804 labelno
= lp
->value
;
1806 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1807 label_type
= lp
->defined
;
1810 label_type
= lp
->referenced
;
1811 lp
->where
= gfc_current_locus
;
1814 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1816 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1821 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1822 && type
== ST_LABEL_FORMAT
)
1824 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1829 lp
->referenced
= type
;
1837 /************** Symbol table management subroutines ****************/
1839 /* Basic details: Fortran 95 requires a potentially unlimited number
1840 of distinct namespaces when compiling a program unit. This case
1841 occurs during a compilation of internal subprograms because all of
1842 the internal subprograms must be read before we can start
1843 generating code for the host.
1845 Given the tricky nature of the Fortran grammar, we must be able to
1846 undo changes made to a symbol table if the current interpretation
1847 of a statement is found to be incorrect. Whenever a symbol is
1848 looked up, we make a copy of it and link to it. All of these
1849 symbols are kept in a singly linked list so that we can commit or
1850 undo the changes at a later time.
1852 A symtree may point to a symbol node outside of its namespace. In
1853 this case, that symbol has been used as a host associated variable
1854 at some previous time. */
1856 /* Allocate a new namespace structure. Copies the implicit types from
1857 PARENT if PARENT_TYPES is set. */
1860 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1864 gfc_intrinsic_op in
;
1867 ns
= gfc_getmem (sizeof (gfc_namespace
));
1868 ns
->sym_root
= NULL
;
1869 ns
->uop_root
= NULL
;
1870 ns
->default_access
= ACCESS_UNKNOWN
;
1871 ns
->parent
= parent
;
1873 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1874 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1876 /* Initialize default implicit types. */
1877 for (i
= 'a'; i
<= 'z'; i
++)
1879 ns
->set_flag
[i
- 'a'] = 0;
1880 ts
= &ns
->default_type
[i
- 'a'];
1882 if (parent_types
&& ns
->parent
!= NULL
)
1884 /* Copy parent settings */
1885 *ts
= ns
->parent
->default_type
[i
- 'a'];
1889 if (gfc_option
.flag_implicit_none
!= 0)
1895 if ('i' <= i
&& i
<= 'n')
1897 ts
->type
= BT_INTEGER
;
1898 ts
->kind
= gfc_default_integer_kind
;
1903 ts
->kind
= gfc_default_real_kind
;
1913 /* Comparison function for symtree nodes. */
1916 compare_symtree (void * _st1
, void * _st2
)
1918 gfc_symtree
*st1
, *st2
;
1920 st1
= (gfc_symtree
*) _st1
;
1921 st2
= (gfc_symtree
*) _st2
;
1923 return strcmp (st1
->name
, st2
->name
);
1927 /* Allocate a new symtree node and associate it with the new symbol. */
1930 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1934 st
= gfc_getmem (sizeof (gfc_symtree
));
1935 st
->name
= gfc_get_string (name
);
1937 gfc_insert_bbt (root
, st
, compare_symtree
);
1942 /* Delete a symbol from the tree. Does not free the symbol itself! */
1945 delete_symtree (gfc_symtree
** root
, const char *name
)
1947 gfc_symtree st
, *st0
;
1949 st0
= gfc_find_symtree (*root
, name
);
1951 st
.name
= gfc_get_string (name
);
1952 gfc_delete_bbt (root
, &st
, compare_symtree
);
1958 /* Given a root symtree node and a name, try to find the symbol within
1959 the namespace. Returns NULL if the symbol is not found. */
1962 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1968 c
= strcmp (name
, st
->name
);
1972 st
= (c
< 0) ? st
->left
: st
->right
;
1979 /* Given a name find a user operator node, creating it if it doesn't
1980 exist. These are much simpler than symbols because they can't be
1981 ambiguous with one another. */
1984 gfc_get_uop (const char *name
)
1989 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1993 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1995 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1996 uop
->name
= gfc_get_string (name
);
1997 uop
->access
= ACCESS_UNKNOWN
;
1998 uop
->ns
= gfc_current_ns
;
2004 /* Given a name find the user operator node. Returns NULL if it does
2008 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
2013 ns
= gfc_current_ns
;
2015 st
= gfc_find_symtree (ns
->uop_root
, name
);
2016 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2020 /* Remove a gfc_symbol structure and everything it points to. */
2023 gfc_free_symbol (gfc_symbol
* sym
)
2029 gfc_free_array_spec (sym
->as
);
2031 free_components (sym
->components
);
2033 gfc_free_expr (sym
->value
);
2035 gfc_free_namelist (sym
->namelist
);
2037 gfc_free_namespace (sym
->formal_ns
);
2039 if (!sym
->attr
.generic_copy
)
2040 gfc_free_interface (sym
->generic
);
2042 gfc_free_formal_arglist (sym
->formal
);
2048 /* Allocate and initialize a new symbol node. */
2051 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2055 p
= gfc_getmem (sizeof (gfc_symbol
));
2057 gfc_clear_ts (&p
->ts
);
2058 gfc_clear_attr (&p
->attr
);
2061 p
->declared_at
= gfc_current_locus
;
2063 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2064 gfc_internal_error ("new_symbol(): Symbol name too long");
2066 p
->name
= gfc_get_string (name
);
2071 /* Generate an error if a symbol is ambiguous. */
2074 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2077 if (st
->n
.sym
->module
)
2078 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2079 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2081 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2082 "from current program unit", name
, st
->n
.sym
->name
);
2086 /* Search for a symtree starting in the current namespace, resorting to
2087 any parent namespaces if requested by a nonzero parent_flag.
2088 Returns nonzero if the name is ambiguous. */
2091 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2092 gfc_symtree
** result
)
2097 ns
= gfc_current_ns
;
2101 st
= gfc_find_symtree (ns
->sym_root
, name
);
2105 /* Ambiguous generic interfaces are permitted, as long
2106 as the specific interfaces are different. */
2107 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2109 ambiguous_symbol (name
, st
);
2128 /* Same, but returns the symbol instead. */
2131 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2132 gfc_symbol
** result
)
2137 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2142 *result
= st
->n
.sym
;
2148 /* Save symbol with the information necessary to back it out. */
2151 save_symbol_data (gfc_symbol
* sym
)
2154 if (sym
->new || sym
->old_symbol
!= NULL
)
2157 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2158 *(sym
->old_symbol
) = *sym
;
2160 sym
->tlink
= changed_syms
;
2165 /* Given a name, find a symbol, or create it if it does not exist yet
2166 in the current namespace. If the symbol is found we make sure that
2169 The integer return code indicates
2171 1 The symbol name was ambiguous
2172 2 The name meant to be established was already host associated.
2174 So if the return value is nonzero, then an error was issued. */
2177 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2182 /* This doesn't usually happen during resolution. */
2184 ns
= gfc_current_ns
;
2186 /* Try to find the symbol in ns. */
2187 st
= gfc_find_symtree (ns
->sym_root
, name
);
2191 /* If not there, create a new symbol. */
2192 p
= gfc_new_symbol (name
, ns
);
2194 /* Add to the list of tentative symbols. */
2195 p
->old_symbol
= NULL
;
2196 p
->tlink
= changed_syms
;
2201 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2208 /* Make sure the existing symbol is OK. Ambiguous
2209 generic interfaces are permitted, as long as the
2210 specific interfaces are different. */
2211 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2213 ambiguous_symbol (name
, st
);
2219 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2221 /* Symbol is from another namespace. */
2222 gfc_error ("Symbol '%s' at %C has already been host associated",
2229 /* Copy in case this symbol is changed. */
2230 save_symbol_data (p
);
2239 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2245 i
= gfc_get_sym_tree (name
, ns
, &st
);
2250 *result
= st
->n
.sym
;
2257 /* Subroutine that searches for a symbol, creating it if it doesn't
2258 exist, but tries to host-associate the symbol if possible. */
2261 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2266 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2269 save_symbol_data (st
->n
.sym
);
2275 if (gfc_current_ns
->parent
!= NULL
)
2277 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2288 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2293 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2298 i
= gfc_get_ha_sym_tree (name
, &st
);
2301 *result
= st
->n
.sym
;
2308 /* Return true if both symbols could refer to the same data object. Does
2309 not take account of aliasing due to equivalence statements. */
2312 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2314 /* Aliasing isn't possible if the symbols have different base types. */
2315 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2318 /* Pointers can point to other pointers, target objects and allocatable
2319 objects. Two allocatable objects cannot share the same storage. */
2320 if (lsym
->attr
.pointer
2321 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2323 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2325 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2332 /* Undoes all the changes made to symbols in the current statement.
2333 This subroutine is made simpler due to the fact that attributes are
2334 never removed once added. */
2337 gfc_undo_symbols (void)
2339 gfc_symbol
*p
, *q
, *old
;
2341 for (p
= changed_syms
; p
; p
= q
)
2347 /* Symbol was new. */
2348 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2352 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2354 gfc_free_symbol (p
);
2358 /* Restore previous state of symbol. Just copy simple stuff. */
2360 old
= p
->old_symbol
;
2362 p
->ts
.type
= old
->ts
.type
;
2363 p
->ts
.kind
= old
->ts
.kind
;
2365 p
->attr
= old
->attr
;
2367 if (p
->value
!= old
->value
)
2369 gfc_free_expr (old
->value
);
2373 if (p
->as
!= old
->as
)
2376 gfc_free_array_spec (p
->as
);
2380 p
->generic
= old
->generic
;
2381 p
->component_access
= old
->component_access
;
2383 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2385 gfc_free_namelist (p
->namelist
);
2391 if (p
->namelist_tail
!= old
->namelist_tail
)
2393 gfc_free_namelist (old
->namelist_tail
);
2394 old
->namelist_tail
->next
= NULL
;
2398 p
->namelist_tail
= old
->namelist_tail
;
2400 if (p
->formal
!= old
->formal
)
2402 gfc_free_formal_arglist (p
->formal
);
2403 p
->formal
= old
->formal
;
2406 gfc_free (p
->old_symbol
);
2407 p
->old_symbol
= NULL
;
2411 changed_syms
= NULL
;
2415 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2416 components of old_symbol that might need deallocation are the "allocatables"
2417 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2418 namelist_tail. In case these differ between old_symbol and sym, it's just
2419 because sym->namelist has gotten a few more items. */
2422 free_old_symbol (gfc_symbol
* sym
)
2424 if (sym
->old_symbol
== NULL
)
2427 if (sym
->old_symbol
->as
!= sym
->as
)
2428 gfc_free_array_spec (sym
->old_symbol
->as
);
2430 if (sym
->old_symbol
->value
!= sym
->value
)
2431 gfc_free_expr (sym
->old_symbol
->value
);
2433 if (sym
->old_symbol
->formal
!= sym
->formal
)
2434 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2436 gfc_free (sym
->old_symbol
);
2437 sym
->old_symbol
= NULL
;
2441 /* Makes the changes made in the current statement permanent-- gets
2442 rid of undo information. */
2445 gfc_commit_symbols (void)
2449 for (p
= changed_syms
; p
; p
= q
)
2456 free_old_symbol (p
);
2458 changed_syms
= NULL
;
2462 /* Makes the changes made in one symbol permanent -- gets rid of undo
2466 gfc_commit_symbol (gfc_symbol
* sym
)
2470 if (changed_syms
== sym
)
2471 changed_syms
= sym
->tlink
;
2474 for (p
= changed_syms
; p
; p
= p
->tlink
)
2475 if (p
->tlink
== sym
)
2477 p
->tlink
= sym
->tlink
;
2486 free_old_symbol (sym
);
2490 /* Recursive function that deletes an entire tree and all the common
2491 head structures it points to. */
2494 free_common_tree (gfc_symtree
* common_tree
)
2496 if (common_tree
== NULL
)
2499 free_common_tree (common_tree
->left
);
2500 free_common_tree (common_tree
->right
);
2502 gfc_free (common_tree
);
2506 /* Recursive function that deletes an entire tree and all the user
2507 operator nodes that it contains. */
2510 free_uop_tree (gfc_symtree
* uop_tree
)
2513 if (uop_tree
== NULL
)
2516 free_uop_tree (uop_tree
->left
);
2517 free_uop_tree (uop_tree
->right
);
2519 gfc_free_interface (uop_tree
->n
.uop
->operator);
2521 gfc_free (uop_tree
->n
.uop
);
2522 gfc_free (uop_tree
);
2526 /* Recursive function that deletes an entire tree and all the symbols
2527 that it contains. */
2530 free_sym_tree (gfc_symtree
* sym_tree
)
2535 if (sym_tree
== NULL
)
2538 free_sym_tree (sym_tree
->left
);
2539 free_sym_tree (sym_tree
->right
);
2541 sym
= sym_tree
->n
.sym
;
2545 gfc_internal_error ("free_sym_tree(): Negative refs");
2547 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2549 /* As formal_ns contains a reference to sym, delete formal_ns just
2550 before the deletion of sym. */
2551 ns
= sym
->formal_ns
;
2552 sym
->formal_ns
= NULL
;
2553 gfc_free_namespace (ns
);
2555 else if (sym
->refs
== 0)
2557 /* Go ahead and delete the symbol. */
2558 gfc_free_symbol (sym
);
2561 gfc_free (sym_tree
);
2565 /* Free the derived type list. */
2568 gfc_free_dt_list (void)
2570 gfc_dt_list
*dt
, *n
;
2572 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2578 gfc_derived_types
= NULL
;
2582 /* Free the gfc_equiv_info's. */
2585 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2589 gfc_free_equiv_infos (s
->next
);
2594 /* Free the gfc_equiv_lists. */
2597 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2601 gfc_free_equiv_lists (l
->next
);
2602 gfc_free_equiv_infos (l
->equiv
);
2607 /* Free a namespace structure and everything below it. Interface
2608 lists associated with intrinsic operators are not freed. These are
2609 taken care of when a specific name is freed. */
2612 gfc_free_namespace (gfc_namespace
* ns
)
2614 gfc_charlen
*cl
, *cl2
;
2615 gfc_namespace
*p
, *q
;
2624 gcc_assert (ns
->refs
== 0);
2626 gfc_free_statements (ns
->code
);
2628 free_sym_tree (ns
->sym_root
);
2629 free_uop_tree (ns
->uop_root
);
2630 free_common_tree (ns
->common_root
);
2632 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2635 gfc_free_expr (cl
->length
);
2639 free_st_labels (ns
->st_labels
);
2641 gfc_free_equiv (ns
->equiv
);
2642 gfc_free_equiv_lists (ns
->equiv_lists
);
2644 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2645 gfc_free_interface (ns
->operator[i
]);
2647 gfc_free_data (ns
->data
);
2651 /* Recursively free any contained namespaces. */
2657 gfc_free_namespace (q
);
2663 gfc_symbol_init_2 (void)
2666 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2671 gfc_symbol_done_2 (void)
2674 gfc_free_namespace (gfc_current_ns
);
2675 gfc_current_ns
= NULL
;
2676 gfc_free_dt_list ();
2680 /* Clear mark bits from symbol nodes associated with a symtree node. */
2683 clear_sym_mark (gfc_symtree
* st
)
2686 st
->n
.sym
->mark
= 0;
2690 /* Recursively traverse the symtree nodes. */
2693 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2699 gfc_traverse_symtree (st
->left
, func
);
2700 gfc_traverse_symtree (st
->right
, func
);
2705 /* Recursive namespace traversal function. */
2708 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2714 if (st
->n
.sym
->mark
== 0)
2715 (*func
) (st
->n
.sym
);
2716 st
->n
.sym
->mark
= 1;
2718 traverse_ns (st
->left
, func
);
2719 traverse_ns (st
->right
, func
);
2723 /* Call a given function for all symbols in the namespace. We take
2724 care that each gfc_symbol node is called exactly once. */
2727 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2730 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2732 traverse_ns (ns
->sym_root
, func
);
2736 /* Return TRUE if the symbol is an automatic variable. */
2738 gfc_is_var_automatic (gfc_symbol
* sym
)
2740 /* Pointer and allocatable variables are never automatic. */
2741 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2743 /* Check for arrays with non-constant size. */
2744 if (sym
->attr
.dimension
&& sym
->as
2745 && !gfc_is_compile_time_shape (sym
->as
))
2747 /* Check for non-constant length character variables. */
2748 if (sym
->ts
.type
== BT_CHARACTER
2750 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2755 /* Given a symbol, mark it as SAVEd if it is allowed. */
2758 save_symbol (gfc_symbol
* sym
)
2761 if (sym
->attr
.use_assoc
)
2764 if (sym
->attr
.in_common
2766 || sym
->attr
.flavor
!= FL_VARIABLE
)
2768 /* Automatic objects are not saved. */
2769 if (gfc_is_var_automatic (sym
))
2771 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2775 /* Mark those symbols which can be SAVEd as such. */
2778 gfc_save_all (gfc_namespace
* ns
)
2781 gfc_traverse_ns (ns
, save_symbol
);
2786 /* Make sure that no changes to symbols are pending. */
2789 gfc_symbol_state(void) {
2791 if (changed_syms
!= NULL
)
2792 gfc_internal_error("Symbol changes still pending!");
2797 /************** Global symbol handling ************/
2800 /* Search a tree for the global symbol. */
2803 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2812 c
= strcmp (name
, symbol
->name
);
2816 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2823 /* Compare two global symbols. Used for managing the BB tree. */
2826 gsym_compare (void * _s1
, void * _s2
)
2828 gfc_gsymbol
*s1
, *s2
;
2830 s1
= (gfc_gsymbol
*)_s1
;
2831 s2
= (gfc_gsymbol
*)_s2
;
2832 return strcmp(s1
->name
, s2
->name
);
2836 /* Get a global symbol, creating it if it doesn't exist. */
2839 gfc_get_gsymbol (const char *name
)
2843 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2847 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2848 s
->type
= GSYM_UNKNOWN
;
2849 s
->name
= gfc_get_string (name
);
2851 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);