1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
97 /* The following static variable indicates whether a particular element has
98 been explicitly set or not. */
100 static int new_flag
[GFC_LETTERS
];
103 /* Handle a correctly parsed IMPLICIT NONE. */
106 gfc_set_implicit_none (void)
110 if (gfc_current_ns
->seen_implicit_none
)
112 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
116 gfc_current_ns
->seen_implicit_none
= 1;
118 for (i
= 0; i
< GFC_LETTERS
; i
++)
120 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
121 gfc_current_ns
->set_flag
[i
] = 1;
126 /* Reset the implicit range flags. */
129 gfc_clear_new_implicit (void)
133 for (i
= 0; i
< GFC_LETTERS
; i
++)
138 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
141 gfc_add_new_implicit_range (int c1
, int c2
)
148 for (i
= c1
; i
<= c2
; i
++)
152 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
165 the new implicit types back into the existing types will work. */
168 gfc_merge_new_implicit (gfc_typespec
* ts
)
172 if (gfc_current_ns
->seen_implicit_none
)
174 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
178 for (i
= 0; i
< GFC_LETTERS
; i
++)
183 if (gfc_current_ns
->set_flag
[i
])
185 gfc_error ("Letter %c already has an IMPLICIT type at %C",
189 gfc_current_ns
->default_type
[i
] = *ts
;
190 gfc_current_ns
->set_flag
[i
] = 1;
197 /* Given a symbol, return a pointer to the typespec for its default type. */
200 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
204 letter
= sym
->name
[0];
205 if (letter
< 'a' || letter
> 'z')
206 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
211 return &ns
->default_type
[letter
- 'a'];
215 /* Given a pointer to a symbol, set its type according to the first
216 letter of its name. Fails if the letter in question has no default
220 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
224 if (sym
->ts
.type
!= BT_UNKNOWN
)
225 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
227 ts
= gfc_get_default_type (sym
, ns
);
229 if (ts
->type
== BT_UNKNOWN
)
231 if (error_flag
&& !sym
->attr
.untyped
)
233 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
234 sym
->name
, &sym
->declared_at
);
235 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
242 sym
->attr
.implicit_type
= 1;
248 /******************** Symbol attribute stuff *********************/
250 /* This is a generic conflict-checker. We do this to avoid having a
251 single conflict in two places. */
253 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
254 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
255 #define conf_std(a, b, std) if (attr->a && attr->b)\
264 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
266 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
267 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
268 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
269 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
270 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
271 *private = "PRIVATE", *recursive
= "RECURSIVE",
272 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
273 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
274 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
275 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
276 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
277 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
278 *volatile_
= "VOLATILE", *protected = "PROTECTED";
279 static const char *threadprivate
= "THREADPRIVATE";
285 where
= &gfc_current_locus
;
287 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
294 /* Check for attributes not allowed in a BLOCK DATA. */
295 if (gfc_current_state () == COMP_BLOCK_DATA
)
299 if (attr
->in_namelist
)
301 if (attr
->allocatable
)
307 if (attr
->access
== ACCESS_PRIVATE
)
309 if (attr
->access
== ACCESS_PUBLIC
)
311 if (attr
->intent
!= INTENT_UNKNOWN
)
317 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
324 conf (dummy
, intrinsic
);
326 conf (dummy
, threadprivate
);
327 conf (pointer
, target
);
328 conf (pointer
, external
);
329 conf (pointer
, intrinsic
);
330 conf (pointer
, elemental
);
331 conf (allocatable
, elemental
);
333 conf (target
, external
);
334 conf (target
, intrinsic
);
335 conf (external
, dimension
); /* See Fortran 95's R504. */
337 conf (external
, intrinsic
);
339 if (attr
->if_source
|| attr
->contained
)
341 conf (external
, subroutine
);
342 conf (external
, function
);
345 conf (allocatable
, pointer
);
346 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
347 conf_std (allocatable
, function
, GFC_STD_F2003
);
348 conf_std (allocatable
, result
, GFC_STD_F2003
);
349 conf (elemental
, recursive
);
351 conf (in_common
, dummy
);
352 conf (in_common
, allocatable
);
353 conf (in_common
, result
);
354 conf (in_common
, save
);
357 conf (dummy
, result
);
359 conf (in_equivalence
, use_assoc
);
360 conf (in_equivalence
, dummy
);
361 conf (in_equivalence
, target
);
362 conf (in_equivalence
, pointer
);
363 conf (in_equivalence
, function
);
364 conf (in_equivalence
, result
);
365 conf (in_equivalence
, entry
);
366 conf (in_equivalence
, allocatable
);
367 conf (in_equivalence
, threadprivate
);
369 conf (in_namelist
, pointer
);
370 conf (in_namelist
, allocatable
);
372 conf (entry
, result
);
374 conf (function
, subroutine
);
376 /* Cray pointer/pointee conflicts. */
377 conf (cray_pointer
, cray_pointee
);
378 conf (cray_pointer
, dimension
);
379 conf (cray_pointer
, pointer
);
380 conf (cray_pointer
, target
);
381 conf (cray_pointer
, allocatable
);
382 conf (cray_pointer
, external
);
383 conf (cray_pointer
, intrinsic
);
384 conf (cray_pointer
, in_namelist
);
385 conf (cray_pointer
, function
);
386 conf (cray_pointer
, subroutine
);
387 conf (cray_pointer
, entry
);
389 conf (cray_pointee
, allocatable
);
390 conf (cray_pointee
, intent
);
391 conf (cray_pointee
, optional
);
392 conf (cray_pointee
, dummy
);
393 conf (cray_pointee
, target
);
394 conf (cray_pointee
, intrinsic
);
395 conf (cray_pointee
, pointer
);
396 conf (cray_pointee
, entry
);
397 conf (cray_pointee
, in_common
);
398 conf (cray_pointee
, in_equivalence
);
399 conf (cray_pointee
, threadprivate
);
402 conf (data
, function
);
404 conf (data
, allocatable
);
405 conf (data
, use_assoc
);
407 conf (protected, intrinsic
)
408 conf (protected, external
)
409 conf (protected, in_common
)
411 conf (value
, pointer
)
412 conf (value
, allocatable
)
413 conf (value
, subroutine
)
414 conf (value
, function
)
415 conf (value
, volatile_
)
416 conf (value
, dimension
)
417 conf (value
, external
)
419 if (attr
->value
&& (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
422 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
426 conf (volatile_
, intrinsic
)
427 conf (volatile_
, external
)
429 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
436 a1
= gfc_code2string (flavors
, attr
->flavor
);
438 if (attr
->in_namelist
439 && attr
->flavor
!= FL_VARIABLE
440 && attr
->flavor
!= FL_UNKNOWN
)
447 switch (attr
->flavor
)
468 conf2 (threadprivate
);
479 if (attr
->subroutine
)
488 conf2(threadprivate
);
493 case PROC_ST_FUNCTION
:
506 conf2 (threadprivate
);
527 conf2 (threadprivate
);
529 if (attr
->intent
!= INTENT_UNKNOWN
)
552 conf2 (threadprivate
);
563 gfc_error ("%s attribute conflicts with %s attribute at %L",
566 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
567 a1
, a2
, name
, where
);
574 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
575 "conflicts with %s attribute at %L", a1
, a2
,
580 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
581 "conflicts with %s attribute in '%s' at %L",
582 a1
, a2
, name
, where
);
591 /* Mark a symbol as referenced. */
594 gfc_set_sym_referenced (gfc_symbol
* sym
)
596 if (sym
->attr
.referenced
)
599 sym
->attr
.referenced
= 1;
601 /* Remember which order dummy variables are accessed in. */
603 sym
->dummy_order
= next_dummy_order
++;
607 /* Common subroutine called by attribute changing subroutines in order
608 to prevent them from changing a symbol that has been
609 use-associated. Returns zero if it is OK to change the symbol,
613 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
616 if (attr
->use_assoc
== 0)
620 where
= &gfc_current_locus
;
623 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
626 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
633 /* Generate an error because of a duplicate attribute. */
636 duplicate_attr (const char *attr
, locus
* where
)
640 where
= &gfc_current_locus
;
642 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
645 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
648 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
)
650 if (check_used (attr
, NULL
, where
))
653 return check_conflict (attr
, NULL
, where
);
657 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
660 if (check_used (attr
, NULL
, where
))
663 if (attr
->allocatable
)
665 duplicate_attr ("ALLOCATABLE", where
);
669 attr
->allocatable
= 1;
670 return check_conflict (attr
, NULL
, where
);
675 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
678 if (check_used (attr
, name
, where
))
683 duplicate_attr ("DIMENSION", where
);
688 return check_conflict (attr
, name
, where
);
693 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
696 if (check_used (attr
, NULL
, where
))
701 duplicate_attr ("EXTERNAL", where
);
707 return check_conflict (attr
, NULL
, where
);
712 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
715 if (check_used (attr
, NULL
, where
))
720 duplicate_attr ("INTRINSIC", where
);
726 return check_conflict (attr
, NULL
, where
);
731 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
734 if (check_used (attr
, NULL
, where
))
739 duplicate_attr ("OPTIONAL", where
);
744 return check_conflict (attr
, NULL
, where
);
749 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
752 if (check_used (attr
, NULL
, where
))
756 return check_conflict (attr
, NULL
, where
);
761 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
764 if (check_used (attr
, NULL
, where
))
767 attr
->cray_pointer
= 1;
768 return check_conflict (attr
, NULL
, where
);
773 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
776 if (check_used (attr
, NULL
, where
))
779 if (attr
->cray_pointee
)
781 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
782 " statements", where
);
786 attr
->cray_pointee
= 1;
787 return check_conflict (attr
, NULL
, where
);
791 gfc_add_protected (symbol_attribute
* attr
, const char *name
, locus
* where
)
793 if (check_used (attr
, name
, where
))
798 if (gfc_notify_std (GFC_STD_LEGACY
,
799 "Duplicate PROTECTED attribute specified at %L",
806 return check_conflict (attr
, name
, where
);
810 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
813 if (check_used (attr
, name
, where
))
817 return check_conflict (attr
, name
, where
);
822 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
825 if (check_used (attr
, name
, where
))
831 ("SAVE attribute at %L cannot be specified in a PURE procedure",
838 if (gfc_notify_std (GFC_STD_LEGACY
,
839 "Duplicate SAVE attribute specified at %L",
846 return check_conflict (attr
, name
, where
);
850 gfc_add_value (symbol_attribute
* attr
, const char *name
, locus
* where
)
853 if (check_used (attr
, name
, where
))
858 if (gfc_notify_std (GFC_STD_LEGACY
,
859 "Duplicate VALUE attribute specified at %L",
866 return check_conflict (attr
, name
, where
);
870 gfc_add_volatile (symbol_attribute
* attr
, const char *name
, locus
* where
)
873 if (check_used (attr
, name
, where
))
878 if (gfc_notify_std (GFC_STD_LEGACY
,
879 "Duplicate VOLATILE attribute specified at %L",
886 return check_conflict (attr
, name
, where
);
891 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
893 if (check_used (attr
, name
, where
))
896 if (attr
->threadprivate
)
898 duplicate_attr ("THREADPRIVATE", where
);
902 attr
->threadprivate
= 1;
903 return check_conflict (attr
, name
, where
);
908 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
911 if (check_used (attr
, NULL
, where
))
916 duplicate_attr ("TARGET", where
);
921 return check_conflict (attr
, NULL
, where
);
926 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
929 if (check_used (attr
, name
, where
))
932 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
934 return check_conflict (attr
, name
, where
);
939 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
942 if (check_used (attr
, name
, where
))
945 /* Duplicate attribute already checked for. */
947 if (check_conflict (attr
, name
, where
) == FAILURE
)
950 if (attr
->flavor
== FL_VARIABLE
)
953 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
957 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
960 /* Duplicate attribute already checked for. */
961 attr
->in_equivalence
= 1;
962 if (check_conflict (attr
, name
, where
) == FAILURE
)
965 if (attr
->flavor
== FL_VARIABLE
)
968 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
973 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
976 if (check_used (attr
, name
, where
))
980 return check_conflict (attr
, name
, where
);
985 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
989 attr
->in_namelist
= 1;
990 return check_conflict (attr
, name
, where
);
995 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
998 if (check_used (attr
, name
, where
))
1002 return check_conflict (attr
, name
, where
);
1007 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
1010 if (check_used (attr
, NULL
, where
))
1013 attr
->elemental
= 1;
1014 return check_conflict (attr
, NULL
, where
);
1019 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
1022 if (check_used (attr
, NULL
, where
))
1026 return check_conflict (attr
, NULL
, where
);
1031 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
1034 if (check_used (attr
, NULL
, where
))
1037 attr
->recursive
= 1;
1038 return check_conflict (attr
, NULL
, where
);
1043 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
1046 if (check_used (attr
, name
, where
))
1051 duplicate_attr ("ENTRY", where
);
1056 return check_conflict (attr
, name
, where
);
1061 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
1064 if (attr
->flavor
!= FL_PROCEDURE
1065 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1069 return check_conflict (attr
, name
, where
);
1074 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1077 if (attr
->flavor
!= FL_PROCEDURE
1078 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1081 attr
->subroutine
= 1;
1082 return check_conflict (attr
, name
, where
);
1087 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1090 if (attr
->flavor
!= FL_PROCEDURE
1091 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1095 return check_conflict (attr
, name
, where
);
1099 /* Flavors are special because some flavors are not what Fortran
1100 considers attributes and can be reaffirmed multiple times. */
1103 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1107 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1108 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1109 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1112 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1115 if (attr
->flavor
!= FL_UNKNOWN
)
1118 where
= &gfc_current_locus
;
1120 gfc_error ("%s attribute conflicts with %s attribute at %L",
1121 gfc_code2string (flavors
, attr
->flavor
),
1122 gfc_code2string (flavors
, f
), where
);
1129 return check_conflict (attr
, name
, where
);
1134 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1135 const char *name
, locus
* where
)
1138 if (check_used (attr
, name
, where
))
1141 if (attr
->flavor
!= FL_PROCEDURE
1142 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1146 where
= &gfc_current_locus
;
1148 if (attr
->proc
!= PROC_UNKNOWN
)
1150 gfc_error ("%s procedure at %L is already declared as %s procedure",
1151 gfc_code2string (procedures
, t
), where
,
1152 gfc_code2string (procedures
, attr
->proc
));
1159 /* Statement functions are always scalar and functions. */
1160 if (t
== PROC_ST_FUNCTION
1161 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1162 || attr
->dimension
))
1165 return check_conflict (attr
, name
, where
);
1170 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1173 if (check_used (attr
, NULL
, where
))
1176 if (attr
->intent
== INTENT_UNKNOWN
)
1178 attr
->intent
= intent
;
1179 return check_conflict (attr
, NULL
, where
);
1183 where
= &gfc_current_locus
;
1185 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1186 gfc_intent_string (attr
->intent
),
1187 gfc_intent_string (intent
), where
);
1193 /* No checks for use-association in public and private statements. */
1196 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1197 const char *name
, locus
* where
)
1200 if (attr
->access
== ACCESS_UNKNOWN
)
1202 attr
->access
= access
;
1203 return check_conflict (attr
, name
, where
);
1207 where
= &gfc_current_locus
;
1208 gfc_error ("ACCESS specification at %L was already specified", where
);
1215 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1216 gfc_formal_arglist
* formal
, locus
* where
)
1219 if (check_used (&sym
->attr
, sym
->name
, where
))
1223 where
= &gfc_current_locus
;
1225 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1226 && sym
->attr
.if_source
!= IFSRC_DECL
)
1228 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1233 sym
->formal
= formal
;
1234 sym
->attr
.if_source
= source
;
1240 /* Add a type to a symbol. */
1243 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1248 where
= &gfc_current_locus
;
1250 if (sym
->ts
.type
!= BT_UNKNOWN
)
1252 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1253 if (!(sym
->ts
.type
== ts
->type
1254 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1255 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1258 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1261 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1262 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1266 flavor
= sym
->attr
.flavor
;
1268 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1269 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1270 && sym
->attr
.subroutine
)
1271 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1273 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1282 /* Clears all attributes. */
1285 gfc_clear_attr (symbol_attribute
* attr
)
1287 memset (attr
, 0, sizeof(symbol_attribute
));
1291 /* Check for missing attributes in the new symbol. Currently does
1292 nothing, but it's not clear that it is unnecessary yet. */
1295 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1296 locus
* where ATTRIBUTE_UNUSED
)
1303 /* Copy an attribute to a symbol attribute, bit by bit. Some
1304 attributes have a lot of side-effects but cannot be present given
1305 where we are called from, so we ignore some bits. */
1308 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1311 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1314 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1316 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1318 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1320 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1322 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1324 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1326 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1328 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1330 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1332 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1334 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1339 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1342 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1345 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1347 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1349 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1352 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1354 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1356 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1358 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1361 if (src
->flavor
!= FL_UNKNOWN
1362 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1365 if (src
->intent
!= INTENT_UNKNOWN
1366 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1369 if (src
->access
!= ACCESS_UNKNOWN
1370 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1373 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1376 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1378 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1381 /* The subroutines that set these bits also cause flavors to be set,
1382 and that has already happened in the original, so don't let it
1387 dest
->intrinsic
= 1;
1396 /************** Component name management ************/
1398 /* Component names of a derived type form their own little namespaces
1399 that are separate from all other spaces. The space is composed of
1400 a singly linked list of gfc_component structures whose head is
1401 located in the parent symbol. */
1404 /* Add a component name to a symbol. The call fails if the name is
1405 already present. On success, the component pointer is modified to
1406 point to the additional component structure. */
1409 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1411 gfc_component
*p
, *tail
;
1415 for (p
= sym
->components
; p
; p
= p
->next
)
1417 if (strcmp (p
->name
, name
) == 0)
1419 gfc_error ("Component '%s' at %C already declared at %L",
1427 /* Allocate a new component. */
1428 p
= gfc_get_component ();
1431 sym
->components
= p
;
1435 p
->name
= gfc_get_string (name
);
1436 p
->loc
= gfc_current_locus
;
1443 /* Recursive function to switch derived types of all symbol in a
1447 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1455 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1456 sym
->ts
.derived
= to
;
1458 switch_types (st
->left
, from
, to
);
1459 switch_types (st
->right
, from
, to
);
1463 /* This subroutine is called when a derived type is used in order to
1464 make the final determination about which version to use. The
1465 standard requires that a type be defined before it is 'used', but
1466 such types can appear in IMPLICIT statements before the actual
1467 definition. 'Using' in this context means declaring a variable to
1468 be that type or using the type constructor.
1470 If a type is used and the components haven't been defined, then we
1471 have to have a derived type in a parent unit. We find the node in
1472 the other namespace and point the symtree node in this namespace to
1473 that node. Further reference to this name point to the correct
1474 node. If we can't find the node in a parent namespace, then we have
1477 This subroutine takes a pointer to a symbol node and returns a
1478 pointer to the translated node or NULL for an error. Usually there
1479 is no translation and we return the node we were passed. */
1482 gfc_use_derived (gfc_symbol
* sym
)
1489 if (sym
->components
!= NULL
)
1490 return sym
; /* Already defined. */
1492 if (sym
->ns
->parent
== NULL
)
1495 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1497 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1501 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1504 /* Get rid of symbol sym, translating all references to s. */
1505 for (i
= 0; i
< GFC_LETTERS
; i
++)
1507 t
= &sym
->ns
->default_type
[i
];
1508 if (t
->derived
== sym
)
1512 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1517 /* Unlink from list of modified symbols. */
1518 gfc_commit_symbol (sym
);
1520 switch_types (sym
->ns
->sym_root
, sym
, s
);
1522 /* TODO: Also have to replace sym -> s in other lists like
1523 namelists, common lists and interface lists. */
1524 gfc_free_symbol (sym
);
1529 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1535 /* Given a derived type node and a component name, try to locate the
1536 component structure. Returns the NULL pointer if the component is
1537 not found or the components are private. */
1540 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1547 sym
= gfc_use_derived (sym
);
1552 for (p
= sym
->components
; p
; p
= p
->next
)
1553 if (strcmp (p
->name
, name
) == 0)
1557 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1561 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1563 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1573 /* Given a symbol, free all of the component structures and everything
1577 free_components (gfc_component
* p
)
1585 gfc_free_array_spec (p
->as
);
1586 gfc_free_expr (p
->initializer
);
1593 /* Set component attributes from a standard symbol attribute
1597 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1600 c
->dimension
= attr
->dimension
;
1601 c
->pointer
= attr
->pointer
;
1602 c
->allocatable
= attr
->allocatable
;
1606 /* Get a standard symbol attribute structure given the component
1610 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1613 gfc_clear_attr (attr
);
1614 attr
->dimension
= c
->dimension
;
1615 attr
->pointer
= c
->pointer
;
1616 attr
->allocatable
= c
->allocatable
;
1620 /******************** Statement label management ********************/
1622 /* Comparison function for statement labels, used for managing the
1626 compare_st_labels (void * a1
, void * b1
)
1628 int a
= ((gfc_st_label
*)a1
)->value
;
1629 int b
= ((gfc_st_label
*)b1
)->value
;
1635 /* Free a single gfc_st_label structure, making sure the tree is not
1636 messed up. This function is called only when some parse error
1640 gfc_free_st_label (gfc_st_label
* label
)
1645 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1647 if (label
->format
!= NULL
)
1648 gfc_free_expr (label
->format
);
1653 /* Free a whole tree of gfc_st_label structures. */
1656 free_st_labels (gfc_st_label
* label
)
1661 free_st_labels (label
->left
);
1662 free_st_labels (label
->right
);
1664 if (label
->format
!= NULL
)
1665 gfc_free_expr (label
->format
);
1670 /* Given a label number, search for and return a pointer to the label
1671 structure, creating it if it does not exist. */
1674 gfc_get_st_label (int labelno
)
1678 /* First see if the label is already in this namespace. */
1679 lp
= gfc_current_ns
->st_labels
;
1682 if (lp
->value
== labelno
)
1685 if (lp
->value
< labelno
)
1691 lp
= gfc_getmem (sizeof (gfc_st_label
));
1693 lp
->value
= labelno
;
1694 lp
->defined
= ST_LABEL_UNKNOWN
;
1695 lp
->referenced
= ST_LABEL_UNKNOWN
;
1697 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1703 /* Called when a statement with a statement label is about to be
1704 accepted. We add the label to the list of the current namespace,
1705 making sure it hasn't been defined previously and referenced
1709 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1713 labelno
= lp
->value
;
1715 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1716 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1717 &lp
->where
, label_locus
);
1720 lp
->where
= *label_locus
;
1724 case ST_LABEL_FORMAT
:
1725 if (lp
->referenced
== ST_LABEL_TARGET
)
1726 gfc_error ("Label %d at %C already referenced as branch target",
1729 lp
->defined
= ST_LABEL_FORMAT
;
1733 case ST_LABEL_TARGET
:
1734 if (lp
->referenced
== ST_LABEL_FORMAT
)
1735 gfc_error ("Label %d at %C already referenced as a format label",
1738 lp
->defined
= ST_LABEL_TARGET
;
1743 lp
->defined
= ST_LABEL_BAD_TARGET
;
1744 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1750 /* Reference a label. Given a label and its type, see if that
1751 reference is consistent with what is known about that label,
1752 updating the unknown state. Returns FAILURE if something goes
1756 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1758 gfc_sl_type label_type
;
1765 labelno
= lp
->value
;
1767 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1768 label_type
= lp
->defined
;
1771 label_type
= lp
->referenced
;
1772 lp
->where
= gfc_current_locus
;
1775 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1777 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1782 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1783 && type
== ST_LABEL_FORMAT
)
1785 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1790 lp
->referenced
= type
;
1798 /************** Symbol table management subroutines ****************/
1800 /* Basic details: Fortran 95 requires a potentially unlimited number
1801 of distinct namespaces when compiling a program unit. This case
1802 occurs during a compilation of internal subprograms because all of
1803 the internal subprograms must be read before we can start
1804 generating code for the host.
1806 Given the tricky nature of the Fortran grammar, we must be able to
1807 undo changes made to a symbol table if the current interpretation
1808 of a statement is found to be incorrect. Whenever a symbol is
1809 looked up, we make a copy of it and link to it. All of these
1810 symbols are kept in a singly linked list so that we can commit or
1811 undo the changes at a later time.
1813 A symtree may point to a symbol node outside of its namespace. In
1814 this case, that symbol has been used as a host associated variable
1815 at some previous time. */
1817 /* Allocate a new namespace structure. Copies the implicit types from
1818 PARENT if PARENT_TYPES is set. */
1821 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1825 gfc_intrinsic_op in
;
1828 ns
= gfc_getmem (sizeof (gfc_namespace
));
1829 ns
->sym_root
= NULL
;
1830 ns
->uop_root
= NULL
;
1831 ns
->default_access
= ACCESS_UNKNOWN
;
1832 ns
->parent
= parent
;
1834 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1835 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1837 /* Initialize default implicit types. */
1838 for (i
= 'a'; i
<= 'z'; i
++)
1840 ns
->set_flag
[i
- 'a'] = 0;
1841 ts
= &ns
->default_type
[i
- 'a'];
1843 if (parent_types
&& ns
->parent
!= NULL
)
1845 /* Copy parent settings */
1846 *ts
= ns
->parent
->default_type
[i
- 'a'];
1850 if (gfc_option
.flag_implicit_none
!= 0)
1856 if ('i' <= i
&& i
<= 'n')
1858 ts
->type
= BT_INTEGER
;
1859 ts
->kind
= gfc_default_integer_kind
;
1864 ts
->kind
= gfc_default_real_kind
;
1874 /* Comparison function for symtree nodes. */
1877 compare_symtree (void * _st1
, void * _st2
)
1879 gfc_symtree
*st1
, *st2
;
1881 st1
= (gfc_symtree
*) _st1
;
1882 st2
= (gfc_symtree
*) _st2
;
1884 return strcmp (st1
->name
, st2
->name
);
1888 /* Allocate a new symtree node and associate it with the new symbol. */
1891 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1895 st
= gfc_getmem (sizeof (gfc_symtree
));
1896 st
->name
= gfc_get_string (name
);
1898 gfc_insert_bbt (root
, st
, compare_symtree
);
1903 /* Delete a symbol from the tree. Does not free the symbol itself! */
1906 delete_symtree (gfc_symtree
** root
, const char *name
)
1908 gfc_symtree st
, *st0
;
1910 st0
= gfc_find_symtree (*root
, name
);
1912 st
.name
= gfc_get_string (name
);
1913 gfc_delete_bbt (root
, &st
, compare_symtree
);
1919 /* Given a root symtree node and a name, try to find the symbol within
1920 the namespace. Returns NULL if the symbol is not found. */
1923 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1929 c
= strcmp (name
, st
->name
);
1933 st
= (c
< 0) ? st
->left
: st
->right
;
1940 /* Given a name find a user operator node, creating it if it doesn't
1941 exist. These are much simpler than symbols because they can't be
1942 ambiguous with one another. */
1945 gfc_get_uop (const char *name
)
1950 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1954 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1956 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1957 uop
->name
= gfc_get_string (name
);
1958 uop
->access
= ACCESS_UNKNOWN
;
1959 uop
->ns
= gfc_current_ns
;
1965 /* Given a name find the user operator node. Returns NULL if it does
1969 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1974 ns
= gfc_current_ns
;
1976 st
= gfc_find_symtree (ns
->uop_root
, name
);
1977 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1981 /* Remove a gfc_symbol structure and everything it points to. */
1984 gfc_free_symbol (gfc_symbol
* sym
)
1990 gfc_free_array_spec (sym
->as
);
1992 free_components (sym
->components
);
1994 gfc_free_expr (sym
->value
);
1996 gfc_free_namelist (sym
->namelist
);
1998 gfc_free_namespace (sym
->formal_ns
);
2000 if (!sym
->attr
.generic_copy
)
2001 gfc_free_interface (sym
->generic
);
2003 gfc_free_formal_arglist (sym
->formal
);
2009 /* Allocate and initialize a new symbol node. */
2012 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2016 p
= gfc_getmem (sizeof (gfc_symbol
));
2018 gfc_clear_ts (&p
->ts
);
2019 gfc_clear_attr (&p
->attr
);
2022 p
->declared_at
= gfc_current_locus
;
2024 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2025 gfc_internal_error ("new_symbol(): Symbol name too long");
2027 p
->name
= gfc_get_string (name
);
2032 /* Generate an error if a symbol is ambiguous. */
2035 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2038 if (st
->n
.sym
->module
)
2039 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2040 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2042 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2043 "from current program unit", name
, st
->n
.sym
->name
);
2047 /* Search for a symtree starting in the current namespace, resorting to
2048 any parent namespaces if requested by a nonzero parent_flag.
2049 Returns nonzero if the name is ambiguous. */
2052 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2053 gfc_symtree
** result
)
2058 ns
= gfc_current_ns
;
2062 st
= gfc_find_symtree (ns
->sym_root
, name
);
2066 /* Ambiguous generic interfaces are permitted, as long
2067 as the specific interfaces are different. */
2068 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2070 ambiguous_symbol (name
, st
);
2089 /* Same, but returns the symbol instead. */
2092 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2093 gfc_symbol
** result
)
2098 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2103 *result
= st
->n
.sym
;
2109 /* Save symbol with the information necessary to back it out. */
2112 save_symbol_data (gfc_symbol
* sym
)
2115 if (sym
->new || sym
->old_symbol
!= NULL
)
2118 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2119 *(sym
->old_symbol
) = *sym
;
2121 sym
->tlink
= changed_syms
;
2126 /* Given a name, find a symbol, or create it if it does not exist yet
2127 in the current namespace. If the symbol is found we make sure that
2130 The integer return code indicates
2132 1 The symbol name was ambiguous
2133 2 The name meant to be established was already host associated.
2135 So if the return value is nonzero, then an error was issued. */
2138 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2143 /* This doesn't usually happen during resolution. */
2145 ns
= gfc_current_ns
;
2147 /* Try to find the symbol in ns. */
2148 st
= gfc_find_symtree (ns
->sym_root
, name
);
2152 /* If not there, create a new symbol. */
2153 p
= gfc_new_symbol (name
, ns
);
2155 /* Add to the list of tentative symbols. */
2156 p
->old_symbol
= NULL
;
2157 p
->tlink
= changed_syms
;
2162 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2169 /* Make sure the existing symbol is OK. Ambiguous
2170 generic interfaces are permitted, as long as the
2171 specific interfaces are different. */
2172 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2174 ambiguous_symbol (name
, st
);
2180 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2182 /* Symbol is from another namespace. */
2183 gfc_error ("Symbol '%s' at %C has already been host associated",
2190 /* Copy in case this symbol is changed. */
2191 save_symbol_data (p
);
2200 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2206 i
= gfc_get_sym_tree (name
, ns
, &st
);
2211 *result
= st
->n
.sym
;
2218 /* Subroutine that searches for a symbol, creating it if it doesn't
2219 exist, but tries to host-associate the symbol if possible. */
2222 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2227 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2230 save_symbol_data (st
->n
.sym
);
2236 if (gfc_current_ns
->parent
!= NULL
)
2238 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2249 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2254 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2259 i
= gfc_get_ha_sym_tree (name
, &st
);
2262 *result
= st
->n
.sym
;
2269 /* Return true if both symbols could refer to the same data object. Does
2270 not take account of aliasing due to equivalence statements. */
2273 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2275 /* Aliasing isn't possible if the symbols have different base types. */
2276 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2279 /* Pointers can point to other pointers, target objects and allocatable
2280 objects. Two allocatable objects cannot share the same storage. */
2281 if (lsym
->attr
.pointer
2282 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2284 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2286 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2293 /* Undoes all the changes made to symbols in the current statement.
2294 This subroutine is made simpler due to the fact that attributes are
2295 never removed once added. */
2298 gfc_undo_symbols (void)
2300 gfc_symbol
*p
, *q
, *old
;
2302 for (p
= changed_syms
; p
; p
= q
)
2308 /* Symbol was new. */
2309 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2313 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2315 gfc_free_symbol (p
);
2319 /* Restore previous state of symbol. Just copy simple stuff. */
2321 old
= p
->old_symbol
;
2323 p
->ts
.type
= old
->ts
.type
;
2324 p
->ts
.kind
= old
->ts
.kind
;
2326 p
->attr
= old
->attr
;
2328 if (p
->value
!= old
->value
)
2330 gfc_free_expr (old
->value
);
2334 if (p
->as
!= old
->as
)
2337 gfc_free_array_spec (p
->as
);
2341 p
->generic
= old
->generic
;
2342 p
->component_access
= old
->component_access
;
2344 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2346 gfc_free_namelist (p
->namelist
);
2352 if (p
->namelist_tail
!= old
->namelist_tail
)
2354 gfc_free_namelist (old
->namelist_tail
);
2355 old
->namelist_tail
->next
= NULL
;
2359 p
->namelist_tail
= old
->namelist_tail
;
2361 if (p
->formal
!= old
->formal
)
2363 gfc_free_formal_arglist (p
->formal
);
2364 p
->formal
= old
->formal
;
2367 gfc_free (p
->old_symbol
);
2368 p
->old_symbol
= NULL
;
2372 changed_syms
= NULL
;
2376 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2377 components of old_symbol that might need deallocation are the "allocatables"
2378 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2379 namelist_tail. In case these differ between old_symbol and sym, it's just
2380 because sym->namelist has gotten a few more items. */
2383 free_old_symbol (gfc_symbol
* sym
)
2385 if (sym
->old_symbol
== NULL
)
2388 if (sym
->old_symbol
->as
!= sym
->as
)
2389 gfc_free_array_spec (sym
->old_symbol
->as
);
2391 if (sym
->old_symbol
->value
!= sym
->value
)
2392 gfc_free_expr (sym
->old_symbol
->value
);
2394 if (sym
->old_symbol
->formal
!= sym
->formal
)
2395 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2397 gfc_free (sym
->old_symbol
);
2398 sym
->old_symbol
= NULL
;
2402 /* Makes the changes made in the current statement permanent-- gets
2403 rid of undo information. */
2406 gfc_commit_symbols (void)
2410 for (p
= changed_syms
; p
; p
= q
)
2417 free_old_symbol (p
);
2419 changed_syms
= NULL
;
2423 /* Makes the changes made in one symbol permanent -- gets rid of undo
2427 gfc_commit_symbol (gfc_symbol
* sym
)
2431 if (changed_syms
== sym
)
2432 changed_syms
= sym
->tlink
;
2435 for (p
= changed_syms
; p
; p
= p
->tlink
)
2436 if (p
->tlink
== sym
)
2438 p
->tlink
= sym
->tlink
;
2447 free_old_symbol (sym
);
2451 /* Recursive function that deletes an entire tree and all the common
2452 head structures it points to. */
2455 free_common_tree (gfc_symtree
* common_tree
)
2457 if (common_tree
== NULL
)
2460 free_common_tree (common_tree
->left
);
2461 free_common_tree (common_tree
->right
);
2463 gfc_free (common_tree
);
2467 /* Recursive function that deletes an entire tree and all the user
2468 operator nodes that it contains. */
2471 free_uop_tree (gfc_symtree
* uop_tree
)
2474 if (uop_tree
== NULL
)
2477 free_uop_tree (uop_tree
->left
);
2478 free_uop_tree (uop_tree
->right
);
2480 gfc_free_interface (uop_tree
->n
.uop
->operator);
2482 gfc_free (uop_tree
->n
.uop
);
2483 gfc_free (uop_tree
);
2487 /* Recursive function that deletes an entire tree and all the symbols
2488 that it contains. */
2491 free_sym_tree (gfc_symtree
* sym_tree
)
2496 if (sym_tree
== NULL
)
2499 free_sym_tree (sym_tree
->left
);
2500 free_sym_tree (sym_tree
->right
);
2502 sym
= sym_tree
->n
.sym
;
2506 gfc_internal_error ("free_sym_tree(): Negative refs");
2508 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2510 /* As formal_ns contains a reference to sym, delete formal_ns just
2511 before the deletion of sym. */
2512 ns
= sym
->formal_ns
;
2513 sym
->formal_ns
= NULL
;
2514 gfc_free_namespace (ns
);
2516 else if (sym
->refs
== 0)
2518 /* Go ahead and delete the symbol. */
2519 gfc_free_symbol (sym
);
2522 gfc_free (sym_tree
);
2526 /* Free a derived type list. */
2529 gfc_free_dt_list (gfc_dt_list
* dt
)
2541 /* Free the gfc_equiv_info's. */
2544 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2548 gfc_free_equiv_infos (s
->next
);
2553 /* Free the gfc_equiv_lists. */
2556 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2560 gfc_free_equiv_lists (l
->next
);
2561 gfc_free_equiv_infos (l
->equiv
);
2566 /* Free a namespace structure and everything below it. Interface
2567 lists associated with intrinsic operators are not freed. These are
2568 taken care of when a specific name is freed. */
2571 gfc_free_namespace (gfc_namespace
* ns
)
2573 gfc_charlen
*cl
, *cl2
;
2574 gfc_namespace
*p
, *q
;
2583 gcc_assert (ns
->refs
== 0);
2585 gfc_free_statements (ns
->code
);
2587 free_sym_tree (ns
->sym_root
);
2588 free_uop_tree (ns
->uop_root
);
2589 free_common_tree (ns
->common_root
);
2591 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2594 gfc_free_expr (cl
->length
);
2598 free_st_labels (ns
->st_labels
);
2600 gfc_free_equiv (ns
->equiv
);
2601 gfc_free_equiv_lists (ns
->equiv_lists
);
2603 gfc_free_dt_list (ns
->derived_types
);
2605 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2606 gfc_free_interface (ns
->operator[i
]);
2608 gfc_free_data (ns
->data
);
2612 /* Recursively free any contained namespaces. */
2618 gfc_free_namespace (q
);
2624 gfc_symbol_init_2 (void)
2627 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2632 gfc_symbol_done_2 (void)
2635 gfc_free_namespace (gfc_current_ns
);
2636 gfc_current_ns
= NULL
;
2640 /* Clear mark bits from symbol nodes associated with a symtree node. */
2643 clear_sym_mark (gfc_symtree
* st
)
2646 st
->n
.sym
->mark
= 0;
2650 /* Recursively traverse the symtree nodes. */
2653 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2659 gfc_traverse_symtree (st
->left
, func
);
2660 gfc_traverse_symtree (st
->right
, func
);
2665 /* Recursive namespace traversal function. */
2668 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2674 if (st
->n
.sym
->mark
== 0)
2675 (*func
) (st
->n
.sym
);
2676 st
->n
.sym
->mark
= 1;
2678 traverse_ns (st
->left
, func
);
2679 traverse_ns (st
->right
, func
);
2683 /* Call a given function for all symbols in the namespace. We take
2684 care that each gfc_symbol node is called exactly once. */
2687 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2690 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2692 traverse_ns (ns
->sym_root
, func
);
2696 /* Return TRUE if the symbol is an automatic variable. */
2698 gfc_is_var_automatic (gfc_symbol
* sym
)
2700 /* Pointer and allocatable variables are never automatic. */
2701 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2703 /* Check for arrays with non-constant size. */
2704 if (sym
->attr
.dimension
&& sym
->as
2705 && !gfc_is_compile_time_shape (sym
->as
))
2707 /* Check for non-constant length character variables. */
2708 if (sym
->ts
.type
== BT_CHARACTER
2710 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2715 /* Given a symbol, mark it as SAVEd if it is allowed. */
2718 save_symbol (gfc_symbol
* sym
)
2721 if (sym
->attr
.use_assoc
)
2724 if (sym
->attr
.in_common
2726 || sym
->attr
.flavor
!= FL_VARIABLE
)
2728 /* Automatic objects are not saved. */
2729 if (gfc_is_var_automatic (sym
))
2731 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2735 /* Mark those symbols which can be SAVEd as such. */
2738 gfc_save_all (gfc_namespace
* ns
)
2741 gfc_traverse_ns (ns
, save_symbol
);
2746 /* Make sure that no changes to symbols are pending. */
2749 gfc_symbol_state(void) {
2751 if (changed_syms
!= NULL
)
2752 gfc_internal_error("Symbol changes still pending!");
2757 /************** Global symbol handling ************/
2760 /* Search a tree for the global symbol. */
2763 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2769 if (strcmp (symbol
->name
, name
) == 0)
2772 s
= gfc_find_gsymbol (symbol
->left
, name
);
2776 s
= gfc_find_gsymbol (symbol
->right
, name
);
2784 /* Compare two global symbols. Used for managing the BB tree. */
2787 gsym_compare (void * _s1
, void * _s2
)
2789 gfc_gsymbol
*s1
, *s2
;
2791 s1
= (gfc_gsymbol
*)_s1
;
2792 s2
= (gfc_gsymbol
*)_s2
;
2793 return strcmp(s1
->name
, s2
->name
);
2797 /* Get a global symbol, creating it if it doesn't exist. */
2800 gfc_get_gsymbol (const char *name
)
2804 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2808 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2809 s
->type
= GSYM_UNKNOWN
;
2810 s
->name
= gfc_get_string (name
);
2812 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);