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
;
1160 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1161 gfc_code2string (flavors
, attr
->flavor
), name
,
1162 gfc_code2string (flavors
, f
), where
);
1164 gfc_error ("%s attribute conflicts with %s attribute at %L",
1165 gfc_code2string (flavors
, attr
->flavor
),
1166 gfc_code2string (flavors
, f
), where
);
1173 return check_conflict (attr
, name
, where
);
1178 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1179 const char *name
, locus
* where
)
1182 if (check_used (attr
, name
, where
))
1185 if (attr
->flavor
!= FL_PROCEDURE
1186 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1190 where
= &gfc_current_locus
;
1192 if (attr
->proc
!= PROC_UNKNOWN
)
1194 gfc_error ("%s procedure at %L is already declared as %s procedure",
1195 gfc_code2string (procedures
, t
), where
,
1196 gfc_code2string (procedures
, attr
->proc
));
1203 /* Statement functions are always scalar and functions. */
1204 if (t
== PROC_ST_FUNCTION
1205 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1206 || attr
->dimension
))
1209 return check_conflict (attr
, name
, where
);
1214 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1217 if (check_used (attr
, NULL
, where
))
1220 if (attr
->intent
== INTENT_UNKNOWN
)
1222 attr
->intent
= intent
;
1223 return check_conflict (attr
, NULL
, where
);
1227 where
= &gfc_current_locus
;
1229 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1230 gfc_intent_string (attr
->intent
),
1231 gfc_intent_string (intent
), where
);
1237 /* No checks for use-association in public and private statements. */
1240 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1241 const char *name
, locus
* where
)
1244 if (attr
->access
== ACCESS_UNKNOWN
)
1246 attr
->access
= access
;
1247 return check_conflict (attr
, name
, where
);
1251 where
= &gfc_current_locus
;
1252 gfc_error ("ACCESS specification at %L was already specified", where
);
1259 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1260 gfc_formal_arglist
* formal
, locus
* where
)
1263 if (check_used (&sym
->attr
, sym
->name
, where
))
1267 where
= &gfc_current_locus
;
1269 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1270 && sym
->attr
.if_source
!= IFSRC_DECL
)
1272 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1277 sym
->formal
= formal
;
1278 sym
->attr
.if_source
= source
;
1284 /* Add a type to a symbol. */
1287 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1292 where
= &gfc_current_locus
;
1294 if (sym
->ts
.type
!= BT_UNKNOWN
)
1296 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1297 if (!(sym
->ts
.type
== ts
->type
1298 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1299 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1302 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1305 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1306 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1310 flavor
= sym
->attr
.flavor
;
1312 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1313 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1314 && sym
->attr
.subroutine
)
1315 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1317 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1326 /* Clears all attributes. */
1329 gfc_clear_attr (symbol_attribute
* attr
)
1331 memset (attr
, 0, sizeof(symbol_attribute
));
1335 /* Check for missing attributes in the new symbol. Currently does
1336 nothing, but it's not clear that it is unnecessary yet. */
1339 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1340 locus
* where ATTRIBUTE_UNUSED
)
1347 /* Copy an attribute to a symbol attribute, bit by bit. Some
1348 attributes have a lot of side-effects but cannot be present given
1349 where we are called from, so we ignore some bits. */
1352 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1355 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1358 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1360 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1362 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1364 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1366 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1368 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1370 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1372 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1374 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1376 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1378 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1383 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1386 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1389 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1391 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1393 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1396 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1398 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1400 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1402 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1405 if (src
->flavor
!= FL_UNKNOWN
1406 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1409 if (src
->intent
!= INTENT_UNKNOWN
1410 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1413 if (src
->access
!= ACCESS_UNKNOWN
1414 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1417 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1420 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1422 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1425 /* The subroutines that set these bits also cause flavors to be set,
1426 and that has already happened in the original, so don't let it
1431 dest
->intrinsic
= 1;
1440 /************** Component name management ************/
1442 /* Component names of a derived type form their own little namespaces
1443 that are separate from all other spaces. The space is composed of
1444 a singly linked list of gfc_component structures whose head is
1445 located in the parent symbol. */
1448 /* Add a component name to a symbol. The call fails if the name is
1449 already present. On success, the component pointer is modified to
1450 point to the additional component structure. */
1453 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1455 gfc_component
*p
, *tail
;
1459 for (p
= sym
->components
; p
; p
= p
->next
)
1461 if (strcmp (p
->name
, name
) == 0)
1463 gfc_error ("Component '%s' at %C already declared at %L",
1471 /* Allocate a new component. */
1472 p
= gfc_get_component ();
1475 sym
->components
= p
;
1479 p
->name
= gfc_get_string (name
);
1480 p
->loc
= gfc_current_locus
;
1487 /* Recursive function to switch derived types of all symbol in a
1491 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1499 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1500 sym
->ts
.derived
= to
;
1502 switch_types (st
->left
, from
, to
);
1503 switch_types (st
->right
, from
, to
);
1507 /* This subroutine is called when a derived type is used in order to
1508 make the final determination about which version to use. The
1509 standard requires that a type be defined before it is 'used', but
1510 such types can appear in IMPLICIT statements before the actual
1511 definition. 'Using' in this context means declaring a variable to
1512 be that type or using the type constructor.
1514 If a type is used and the components haven't been defined, then we
1515 have to have a derived type in a parent unit. We find the node in
1516 the other namespace and point the symtree node in this namespace to
1517 that node. Further reference to this name point to the correct
1518 node. If we can't find the node in a parent namespace, then we have
1521 This subroutine takes a pointer to a symbol node and returns a
1522 pointer to the translated node or NULL for an error. Usually there
1523 is no translation and we return the node we were passed. */
1526 gfc_use_derived (gfc_symbol
* sym
)
1533 if (sym
->components
!= NULL
)
1534 return sym
; /* Already defined. */
1536 if (sym
->ns
->parent
== NULL
)
1539 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1541 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1545 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1548 /* Get rid of symbol sym, translating all references to s. */
1549 for (i
= 0; i
< GFC_LETTERS
; i
++)
1551 t
= &sym
->ns
->default_type
[i
];
1552 if (t
->derived
== sym
)
1556 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1561 /* Unlink from list of modified symbols. */
1562 gfc_commit_symbol (sym
);
1564 switch_types (sym
->ns
->sym_root
, sym
, s
);
1566 /* TODO: Also have to replace sym -> s in other lists like
1567 namelists, common lists and interface lists. */
1568 gfc_free_symbol (sym
);
1573 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1579 /* Given a derived type node and a component name, try to locate the
1580 component structure. Returns the NULL pointer if the component is
1581 not found or the components are private. */
1584 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1591 sym
= gfc_use_derived (sym
);
1596 for (p
= sym
->components
; p
; p
= p
->next
)
1597 if (strcmp (p
->name
, name
) == 0)
1601 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1605 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1607 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1617 /* Given a symbol, free all of the component structures and everything
1621 free_components (gfc_component
* p
)
1629 gfc_free_array_spec (p
->as
);
1630 gfc_free_expr (p
->initializer
);
1637 /* Set component attributes from a standard symbol attribute
1641 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1644 c
->dimension
= attr
->dimension
;
1645 c
->pointer
= attr
->pointer
;
1646 c
->allocatable
= attr
->allocatable
;
1650 /* Get a standard symbol attribute structure given the component
1654 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1657 gfc_clear_attr (attr
);
1658 attr
->dimension
= c
->dimension
;
1659 attr
->pointer
= c
->pointer
;
1660 attr
->allocatable
= c
->allocatable
;
1664 /******************** Statement label management ********************/
1666 /* Comparison function for statement labels, used for managing the
1670 compare_st_labels (void * a1
, void * b1
)
1672 int a
= ((gfc_st_label
*)a1
)->value
;
1673 int b
= ((gfc_st_label
*)b1
)->value
;
1679 /* Free a single gfc_st_label structure, making sure the tree is not
1680 messed up. This function is called only when some parse error
1684 gfc_free_st_label (gfc_st_label
* label
)
1689 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1691 if (label
->format
!= NULL
)
1692 gfc_free_expr (label
->format
);
1697 /* Free a whole tree of gfc_st_label structures. */
1700 free_st_labels (gfc_st_label
* label
)
1705 free_st_labels (label
->left
);
1706 free_st_labels (label
->right
);
1708 if (label
->format
!= NULL
)
1709 gfc_free_expr (label
->format
);
1714 /* Given a label number, search for and return a pointer to the label
1715 structure, creating it if it does not exist. */
1718 gfc_get_st_label (int labelno
)
1722 /* First see if the label is already in this namespace. */
1723 lp
= gfc_current_ns
->st_labels
;
1726 if (lp
->value
== labelno
)
1729 if (lp
->value
< labelno
)
1735 lp
= gfc_getmem (sizeof (gfc_st_label
));
1737 lp
->value
= labelno
;
1738 lp
->defined
= ST_LABEL_UNKNOWN
;
1739 lp
->referenced
= ST_LABEL_UNKNOWN
;
1741 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1747 /* Called when a statement with a statement label is about to be
1748 accepted. We add the label to the list of the current namespace,
1749 making sure it hasn't been defined previously and referenced
1753 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1757 labelno
= lp
->value
;
1759 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1760 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1761 &lp
->where
, label_locus
);
1764 lp
->where
= *label_locus
;
1768 case ST_LABEL_FORMAT
:
1769 if (lp
->referenced
== ST_LABEL_TARGET
)
1770 gfc_error ("Label %d at %C already referenced as branch target",
1773 lp
->defined
= ST_LABEL_FORMAT
;
1777 case ST_LABEL_TARGET
:
1778 if (lp
->referenced
== ST_LABEL_FORMAT
)
1779 gfc_error ("Label %d at %C already referenced as a format label",
1782 lp
->defined
= ST_LABEL_TARGET
;
1787 lp
->defined
= ST_LABEL_BAD_TARGET
;
1788 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1794 /* Reference a label. Given a label and its type, see if that
1795 reference is consistent with what is known about that label,
1796 updating the unknown state. Returns FAILURE if something goes
1800 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1802 gfc_sl_type label_type
;
1809 labelno
= lp
->value
;
1811 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1812 label_type
= lp
->defined
;
1815 label_type
= lp
->referenced
;
1816 lp
->where
= gfc_current_locus
;
1819 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1821 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1826 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1827 && type
== ST_LABEL_FORMAT
)
1829 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1834 lp
->referenced
= type
;
1842 /************** Symbol table management subroutines ****************/
1844 /* Basic details: Fortran 95 requires a potentially unlimited number
1845 of distinct namespaces when compiling a program unit. This case
1846 occurs during a compilation of internal subprograms because all of
1847 the internal subprograms must be read before we can start
1848 generating code for the host.
1850 Given the tricky nature of the Fortran grammar, we must be able to
1851 undo changes made to a symbol table if the current interpretation
1852 of a statement is found to be incorrect. Whenever a symbol is
1853 looked up, we make a copy of it and link to it. All of these
1854 symbols are kept in a singly linked list so that we can commit or
1855 undo the changes at a later time.
1857 A symtree may point to a symbol node outside of its namespace. In
1858 this case, that symbol has been used as a host associated variable
1859 at some previous time. */
1861 /* Allocate a new namespace structure. Copies the implicit types from
1862 PARENT if PARENT_TYPES is set. */
1865 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1869 gfc_intrinsic_op in
;
1872 ns
= gfc_getmem (sizeof (gfc_namespace
));
1873 ns
->sym_root
= NULL
;
1874 ns
->uop_root
= NULL
;
1875 ns
->default_access
= ACCESS_UNKNOWN
;
1876 ns
->parent
= parent
;
1878 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1879 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1881 /* Initialize default implicit types. */
1882 for (i
= 'a'; i
<= 'z'; i
++)
1884 ns
->set_flag
[i
- 'a'] = 0;
1885 ts
= &ns
->default_type
[i
- 'a'];
1887 if (parent_types
&& ns
->parent
!= NULL
)
1889 /* Copy parent settings */
1890 *ts
= ns
->parent
->default_type
[i
- 'a'];
1894 if (gfc_option
.flag_implicit_none
!= 0)
1900 if ('i' <= i
&& i
<= 'n')
1902 ts
->type
= BT_INTEGER
;
1903 ts
->kind
= gfc_default_integer_kind
;
1908 ts
->kind
= gfc_default_real_kind
;
1918 /* Comparison function for symtree nodes. */
1921 compare_symtree (void * _st1
, void * _st2
)
1923 gfc_symtree
*st1
, *st2
;
1925 st1
= (gfc_symtree
*) _st1
;
1926 st2
= (gfc_symtree
*) _st2
;
1928 return strcmp (st1
->name
, st2
->name
);
1932 /* Allocate a new symtree node and associate it with the new symbol. */
1935 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1939 st
= gfc_getmem (sizeof (gfc_symtree
));
1940 st
->name
= gfc_get_string (name
);
1942 gfc_insert_bbt (root
, st
, compare_symtree
);
1947 /* Delete a symbol from the tree. Does not free the symbol itself! */
1950 delete_symtree (gfc_symtree
** root
, const char *name
)
1952 gfc_symtree st
, *st0
;
1954 st0
= gfc_find_symtree (*root
, name
);
1956 st
.name
= gfc_get_string (name
);
1957 gfc_delete_bbt (root
, &st
, compare_symtree
);
1963 /* Given a root symtree node and a name, try to find the symbol within
1964 the namespace. Returns NULL if the symbol is not found. */
1967 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1973 c
= strcmp (name
, st
->name
);
1977 st
= (c
< 0) ? st
->left
: st
->right
;
1984 /* Given a name find a user operator node, creating it if it doesn't
1985 exist. These are much simpler than symbols because they can't be
1986 ambiguous with one another. */
1989 gfc_get_uop (const char *name
)
1994 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1998 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2000 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2001 uop
->name
= gfc_get_string (name
);
2002 uop
->access
= ACCESS_UNKNOWN
;
2003 uop
->ns
= gfc_current_ns
;
2009 /* Given a name find the user operator node. Returns NULL if it does
2013 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
2018 ns
= gfc_current_ns
;
2020 st
= gfc_find_symtree (ns
->uop_root
, name
);
2021 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2025 /* Remove a gfc_symbol structure and everything it points to. */
2028 gfc_free_symbol (gfc_symbol
* sym
)
2034 gfc_free_array_spec (sym
->as
);
2036 free_components (sym
->components
);
2038 gfc_free_expr (sym
->value
);
2040 gfc_free_namelist (sym
->namelist
);
2042 gfc_free_namespace (sym
->formal_ns
);
2044 if (!sym
->attr
.generic_copy
)
2045 gfc_free_interface (sym
->generic
);
2047 gfc_free_formal_arglist (sym
->formal
);
2053 /* Allocate and initialize a new symbol node. */
2056 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2060 p
= gfc_getmem (sizeof (gfc_symbol
));
2062 gfc_clear_ts (&p
->ts
);
2063 gfc_clear_attr (&p
->attr
);
2066 p
->declared_at
= gfc_current_locus
;
2068 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2069 gfc_internal_error ("new_symbol(): Symbol name too long");
2071 p
->name
= gfc_get_string (name
);
2076 /* Generate an error if a symbol is ambiguous. */
2079 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2082 if (st
->n
.sym
->module
)
2083 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2084 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2086 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2087 "from current program unit", name
, st
->n
.sym
->name
);
2091 /* Search for a symtree starting in the current namespace, resorting to
2092 any parent namespaces if requested by a nonzero parent_flag.
2093 Returns nonzero if the name is ambiguous. */
2096 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2097 gfc_symtree
** result
)
2102 ns
= gfc_current_ns
;
2106 st
= gfc_find_symtree (ns
->sym_root
, name
);
2110 /* Ambiguous generic interfaces are permitted, as long
2111 as the specific interfaces are different. */
2112 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2114 ambiguous_symbol (name
, st
);
2133 /* Same, but returns the symbol instead. */
2136 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2137 gfc_symbol
** result
)
2142 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2147 *result
= st
->n
.sym
;
2153 /* Save symbol with the information necessary to back it out. */
2156 save_symbol_data (gfc_symbol
* sym
)
2159 if (sym
->new || sym
->old_symbol
!= NULL
)
2162 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2163 *(sym
->old_symbol
) = *sym
;
2165 sym
->tlink
= changed_syms
;
2170 /* Given a name, find a symbol, or create it if it does not exist yet
2171 in the current namespace. If the symbol is found we make sure that
2174 The integer return code indicates
2176 1 The symbol name was ambiguous
2177 2 The name meant to be established was already host associated.
2179 So if the return value is nonzero, then an error was issued. */
2182 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2187 /* This doesn't usually happen during resolution. */
2189 ns
= gfc_current_ns
;
2191 /* Try to find the symbol in ns. */
2192 st
= gfc_find_symtree (ns
->sym_root
, name
);
2196 /* If not there, create a new symbol. */
2197 p
= gfc_new_symbol (name
, ns
);
2199 /* Add to the list of tentative symbols. */
2200 p
->old_symbol
= NULL
;
2201 p
->tlink
= changed_syms
;
2206 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2213 /* Make sure the existing symbol is OK. Ambiguous
2214 generic interfaces are permitted, as long as the
2215 specific interfaces are different. */
2216 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2218 ambiguous_symbol (name
, st
);
2224 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2226 /* Symbol is from another namespace. */
2227 gfc_error ("Symbol '%s' at %C has already been host associated",
2234 /* Copy in case this symbol is changed. */
2235 save_symbol_data (p
);
2244 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2250 i
= gfc_get_sym_tree (name
, ns
, &st
);
2255 *result
= st
->n
.sym
;
2262 /* Subroutine that searches for a symbol, creating it if it doesn't
2263 exist, but tries to host-associate the symbol if possible. */
2266 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2271 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2274 save_symbol_data (st
->n
.sym
);
2280 if (gfc_current_ns
->parent
!= NULL
)
2282 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2293 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2298 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2303 i
= gfc_get_ha_sym_tree (name
, &st
);
2306 *result
= st
->n
.sym
;
2313 /* Return true if both symbols could refer to the same data object. Does
2314 not take account of aliasing due to equivalence statements. */
2317 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2319 /* Aliasing isn't possible if the symbols have different base types. */
2320 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2323 /* Pointers can point to other pointers, target objects and allocatable
2324 objects. Two allocatable objects cannot share the same storage. */
2325 if (lsym
->attr
.pointer
2326 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2328 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2330 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2337 /* Undoes all the changes made to symbols in the current statement.
2338 This subroutine is made simpler due to the fact that attributes are
2339 never removed once added. */
2342 gfc_undo_symbols (void)
2344 gfc_symbol
*p
, *q
, *old
;
2346 for (p
= changed_syms
; p
; p
= q
)
2352 /* Symbol was new. */
2353 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2357 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2359 gfc_free_symbol (p
);
2363 /* Restore previous state of symbol. Just copy simple stuff. */
2365 old
= p
->old_symbol
;
2367 p
->ts
.type
= old
->ts
.type
;
2368 p
->ts
.kind
= old
->ts
.kind
;
2370 p
->attr
= old
->attr
;
2372 if (p
->value
!= old
->value
)
2374 gfc_free_expr (old
->value
);
2378 if (p
->as
!= old
->as
)
2381 gfc_free_array_spec (p
->as
);
2385 p
->generic
= old
->generic
;
2386 p
->component_access
= old
->component_access
;
2388 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2390 gfc_free_namelist (p
->namelist
);
2396 if (p
->namelist_tail
!= old
->namelist_tail
)
2398 gfc_free_namelist (old
->namelist_tail
);
2399 old
->namelist_tail
->next
= NULL
;
2403 p
->namelist_tail
= old
->namelist_tail
;
2405 if (p
->formal
!= old
->formal
)
2407 gfc_free_formal_arglist (p
->formal
);
2408 p
->formal
= old
->formal
;
2411 gfc_free (p
->old_symbol
);
2412 p
->old_symbol
= NULL
;
2416 changed_syms
= NULL
;
2420 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2421 components of old_symbol that might need deallocation are the "allocatables"
2422 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2423 namelist_tail. In case these differ between old_symbol and sym, it's just
2424 because sym->namelist has gotten a few more items. */
2427 free_old_symbol (gfc_symbol
* sym
)
2429 if (sym
->old_symbol
== NULL
)
2432 if (sym
->old_symbol
->as
!= sym
->as
)
2433 gfc_free_array_spec (sym
->old_symbol
->as
);
2435 if (sym
->old_symbol
->value
!= sym
->value
)
2436 gfc_free_expr (sym
->old_symbol
->value
);
2438 if (sym
->old_symbol
->formal
!= sym
->formal
)
2439 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2441 gfc_free (sym
->old_symbol
);
2442 sym
->old_symbol
= NULL
;
2446 /* Makes the changes made in the current statement permanent-- gets
2447 rid of undo information. */
2450 gfc_commit_symbols (void)
2454 for (p
= changed_syms
; p
; p
= q
)
2461 free_old_symbol (p
);
2463 changed_syms
= NULL
;
2467 /* Makes the changes made in one symbol permanent -- gets rid of undo
2471 gfc_commit_symbol (gfc_symbol
* sym
)
2475 if (changed_syms
== sym
)
2476 changed_syms
= sym
->tlink
;
2479 for (p
= changed_syms
; p
; p
= p
->tlink
)
2480 if (p
->tlink
== sym
)
2482 p
->tlink
= sym
->tlink
;
2491 free_old_symbol (sym
);
2495 /* Recursive function that deletes an entire tree and all the common
2496 head structures it points to. */
2499 free_common_tree (gfc_symtree
* common_tree
)
2501 if (common_tree
== NULL
)
2504 free_common_tree (common_tree
->left
);
2505 free_common_tree (common_tree
->right
);
2507 gfc_free (common_tree
);
2511 /* Recursive function that deletes an entire tree and all the user
2512 operator nodes that it contains. */
2515 free_uop_tree (gfc_symtree
* uop_tree
)
2518 if (uop_tree
== NULL
)
2521 free_uop_tree (uop_tree
->left
);
2522 free_uop_tree (uop_tree
->right
);
2524 gfc_free_interface (uop_tree
->n
.uop
->operator);
2526 gfc_free (uop_tree
->n
.uop
);
2527 gfc_free (uop_tree
);
2531 /* Recursive function that deletes an entire tree and all the symbols
2532 that it contains. */
2535 free_sym_tree (gfc_symtree
* sym_tree
)
2540 if (sym_tree
== NULL
)
2543 free_sym_tree (sym_tree
->left
);
2544 free_sym_tree (sym_tree
->right
);
2546 sym
= sym_tree
->n
.sym
;
2550 gfc_internal_error ("free_sym_tree(): Negative refs");
2552 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2554 /* As formal_ns contains a reference to sym, delete formal_ns just
2555 before the deletion of sym. */
2556 ns
= sym
->formal_ns
;
2557 sym
->formal_ns
= NULL
;
2558 gfc_free_namespace (ns
);
2560 else if (sym
->refs
== 0)
2562 /* Go ahead and delete the symbol. */
2563 gfc_free_symbol (sym
);
2566 gfc_free (sym_tree
);
2570 /* Free the derived type list. */
2573 gfc_free_dt_list (void)
2575 gfc_dt_list
*dt
, *n
;
2577 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2583 gfc_derived_types
= NULL
;
2587 /* Free the gfc_equiv_info's. */
2590 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2594 gfc_free_equiv_infos (s
->next
);
2599 /* Free the gfc_equiv_lists. */
2602 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2606 gfc_free_equiv_lists (l
->next
);
2607 gfc_free_equiv_infos (l
->equiv
);
2612 /* Free a namespace structure and everything below it. Interface
2613 lists associated with intrinsic operators are not freed. These are
2614 taken care of when a specific name is freed. */
2617 gfc_free_namespace (gfc_namespace
* ns
)
2619 gfc_charlen
*cl
, *cl2
;
2620 gfc_namespace
*p
, *q
;
2629 gcc_assert (ns
->refs
== 0);
2631 gfc_free_statements (ns
->code
);
2633 free_sym_tree (ns
->sym_root
);
2634 free_uop_tree (ns
->uop_root
);
2635 free_common_tree (ns
->common_root
);
2637 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2640 gfc_free_expr (cl
->length
);
2644 free_st_labels (ns
->st_labels
);
2646 gfc_free_equiv (ns
->equiv
);
2647 gfc_free_equiv_lists (ns
->equiv_lists
);
2649 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2650 gfc_free_interface (ns
->operator[i
]);
2652 gfc_free_data (ns
->data
);
2656 /* Recursively free any contained namespaces. */
2662 gfc_free_namespace (q
);
2668 gfc_symbol_init_2 (void)
2671 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2676 gfc_symbol_done_2 (void)
2679 gfc_free_namespace (gfc_current_ns
);
2680 gfc_current_ns
= NULL
;
2681 gfc_free_dt_list ();
2685 /* Clear mark bits from symbol nodes associated with a symtree node. */
2688 clear_sym_mark (gfc_symtree
* st
)
2691 st
->n
.sym
->mark
= 0;
2695 /* Recursively traverse the symtree nodes. */
2698 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2704 gfc_traverse_symtree (st
->left
, func
);
2705 gfc_traverse_symtree (st
->right
, func
);
2710 /* Recursive namespace traversal function. */
2713 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2719 if (st
->n
.sym
->mark
== 0)
2720 (*func
) (st
->n
.sym
);
2721 st
->n
.sym
->mark
= 1;
2723 traverse_ns (st
->left
, func
);
2724 traverse_ns (st
->right
, func
);
2728 /* Call a given function for all symbols in the namespace. We take
2729 care that each gfc_symbol node is called exactly once. */
2732 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2735 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2737 traverse_ns (ns
->sym_root
, func
);
2741 /* Return TRUE if the symbol is an automatic variable. */
2743 gfc_is_var_automatic (gfc_symbol
* sym
)
2745 /* Pointer and allocatable variables are never automatic. */
2746 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2748 /* Check for arrays with non-constant size. */
2749 if (sym
->attr
.dimension
&& sym
->as
2750 && !gfc_is_compile_time_shape (sym
->as
))
2752 /* Check for non-constant length character variables. */
2753 if (sym
->ts
.type
== BT_CHARACTER
2755 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2760 /* Given a symbol, mark it as SAVEd if it is allowed. */
2763 save_symbol (gfc_symbol
* sym
)
2766 if (sym
->attr
.use_assoc
)
2769 if (sym
->attr
.in_common
2771 || sym
->attr
.flavor
!= FL_VARIABLE
)
2773 /* Automatic objects are not saved. */
2774 if (gfc_is_var_automatic (sym
))
2776 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2780 /* Mark those symbols which can be SAVEd as such. */
2783 gfc_save_all (gfc_namespace
* ns
)
2786 gfc_traverse_ns (ns
, save_symbol
);
2791 /* Make sure that no changes to symbols are pending. */
2794 gfc_symbol_state(void) {
2796 if (changed_syms
!= NULL
)
2797 gfc_internal_error("Symbol changes still pending!");
2802 /************** Global symbol handling ************/
2805 /* Search a tree for the global symbol. */
2808 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2817 c
= strcmp (name
, symbol
->name
);
2821 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2828 /* Compare two global symbols. Used for managing the BB tree. */
2831 gsym_compare (void * _s1
, void * _s2
)
2833 gfc_gsymbol
*s1
, *s2
;
2835 s1
= (gfc_gsymbol
*)_s1
;
2836 s2
= (gfc_gsymbol
*)_s2
;
2837 return strcmp(s1
->name
, s2
->name
);
2841 /* Get a global symbol, creating it if it doesn't exist. */
2844 gfc_get_gsymbol (const char *name
)
2848 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2852 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2853 s
->type
= GSYM_UNKNOWN
;
2854 s
->name
= gfc_get_string (name
);
2856 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);