85ed70eb352dadbf44db439adce044c26d44f292
1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
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
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors
[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
37 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
38 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
39 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 const mstring procedures
[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
46 minit ("MODULE-PROC", PROC_MODULE
),
47 minit ("INTERNAL-PROC", PROC_INTERNAL
),
48 minit ("DUMMY-PROC", PROC_DUMMY
),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
55 const mstring intents
[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
58 minit ("IN", INTENT_IN
),
59 minit ("OUT", INTENT_OUT
),
60 minit ("INOUT", INTENT_INOUT
),
64 const mstring access_types
[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
67 minit ("PUBLIC", ACCESS_PUBLIC
),
68 minit ("PRIVATE", ACCESS_PRIVATE
),
72 const mstring ifsrc_types
[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN
),
75 minit ("DECL", IFSRC_DECL
),
76 minit ("BODY", IFSRC_IFBODY
),
77 minit ("USAGE", IFSRC_USAGE
)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order
= 1;
87 gfc_namespace
*gfc_current_ns
;
89 gfc_gsymbol
*gfc_gsym_root
= NULL
;
91 static gfc_symbol
*changed_syms
= NULL
;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag
[GFC_LETTERS
];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 if (gfc_current_ns
->seen_implicit_none
)
111 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
115 gfc_current_ns
->seen_implicit_none
= 1;
117 for (i
= 0; i
< GFC_LETTERS
; i
++)
119 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
120 gfc_current_ns
->set_flag
[i
] = 1;
125 /* Reset the implicit range flags. */
128 gfc_clear_new_implicit (void)
132 for (i
= 0; i
< GFC_LETTERS
; i
++)
137 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
140 gfc_add_new_implicit_range (int c1
, int c2
)
147 for (i
= c1
; i
<= c2
; i
++)
151 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
163 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
164 the new implicit types back into the existing types will work. */
167 gfc_merge_new_implicit (gfc_typespec
* ts
)
171 if (gfc_current_ns
->seen_implicit_none
)
173 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
177 for (i
= 0; i
< GFC_LETTERS
; i
++)
182 if (gfc_current_ns
->set_flag
[i
])
184 gfc_error ("Letter %c already has an IMPLICIT type at %C",
188 gfc_current_ns
->default_type
[i
] = *ts
;
189 gfc_current_ns
->set_flag
[i
] = 1;
196 /* Given a symbol, return a pointer to the typespec for its default type. */
199 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
203 letter
= sym
->name
[0];
204 if (letter
< 'a' || letter
> 'z')
205 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
210 return &ns
->default_type
[letter
- 'a'];
214 /* Given a pointer to a symbol, set its type according to the first
215 letter of its name. Fails if the letter in question has no default
219 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
223 if (sym
->ts
.type
!= BT_UNKNOWN
)
224 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
226 ts
= gfc_get_default_type (sym
, ns
);
228 if (ts
->type
== BT_UNKNOWN
)
230 if (error_flag
&& !sym
->attr
.untyped
)
232 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
233 sym
->name
, &sym
->declared_at
);
234 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
241 sym
->attr
.implicit_type
= 1;
247 /******************** Symbol attribute stuff *********************/
249 /* This is a generic conflict-checker. We do this to avoid having a
250 single conflict in two places. */
252 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
253 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
256 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
258 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
259 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
260 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
261 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
262 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
263 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
264 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
265 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
266 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
267 *cray_pointee
= "CRAY POINTEE";
272 where
= &gfc_current_locus
;
274 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
281 /* Check for attributes not allowed in a BLOCK DATA. */
282 if (gfc_current_state () == COMP_BLOCK_DATA
)
286 if (attr
->allocatable
)
292 if (attr
->access
== ACCESS_PRIVATE
)
294 if (attr
->access
== ACCESS_PUBLIC
)
296 if (attr
->intent
!= INTENT_UNKNOWN
)
302 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
309 conf (pointer
, target
);
310 conf (pointer
, external
);
311 conf (pointer
, intrinsic
);
312 conf (target
, external
);
313 conf (target
, intrinsic
);
314 conf (external
, dimension
); /* See Fortran 95's R504. */
316 conf (external
, intrinsic
);
317 conf (allocatable
, pointer
);
318 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
319 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
320 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
321 conf (elemental
, recursive
);
323 conf (in_common
, dummy
);
324 conf (in_common
, allocatable
);
325 conf (in_common
, result
);
326 conf (in_common
, save
);
329 conf (dummy
, result
);
331 conf (in_equivalence
, use_assoc
);
332 conf (in_equivalence
, dummy
);
333 conf (in_equivalence
, target
);
334 conf (in_equivalence
, pointer
);
335 conf (in_equivalence
, function
);
336 conf (in_equivalence
, result
);
337 conf (in_equivalence
, entry
);
338 conf (in_equivalence
, allocatable
);
340 conf (in_namelist
, pointer
);
341 conf (in_namelist
, allocatable
);
343 conf (entry
, result
);
345 conf (function
, subroutine
);
347 /* Cray pointer/pointee conflicts. */
348 conf (cray_pointer
, cray_pointee
);
349 conf (cray_pointer
, dimension
);
350 conf (cray_pointer
, pointer
);
351 conf (cray_pointer
, target
);
352 conf (cray_pointer
, allocatable
);
353 conf (cray_pointer
, external
);
354 conf (cray_pointer
, intrinsic
);
355 conf (cray_pointer
, in_namelist
);
356 conf (cray_pointer
, function
);
357 conf (cray_pointer
, subroutine
);
358 conf (cray_pointer
, entry
);
360 conf (cray_pointee
, allocatable
);
361 conf (cray_pointee
, intent
);
362 conf (cray_pointee
, optional
);
363 conf (cray_pointee
, dummy
);
364 conf (cray_pointee
, target
);
365 conf (cray_pointee
, external
);
366 conf (cray_pointee
, intrinsic
);
367 conf (cray_pointee
, pointer
);
368 conf (cray_pointee
, function
);
369 conf (cray_pointee
, subroutine
);
370 conf (cray_pointee
, entry
);
371 conf (cray_pointee
, in_common
);
372 conf (cray_pointee
, in_equivalence
);
374 a1
= gfc_code2string (flavors
, attr
->flavor
);
376 if (attr
->in_namelist
377 && attr
->flavor
!= FL_VARIABLE
378 && attr
->flavor
!= FL_UNKNOWN
)
385 switch (attr
->flavor
)
412 if (attr
->subroutine
)
425 case PROC_ST_FUNCTION
:
459 if (attr
->intent
!= INTENT_UNKNOWN
)
489 gfc_error ("%s attribute conflicts with %s attribute at %L",
492 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
493 a1
, a2
, name
, where
);
502 /* Mark a symbol as referenced. */
505 gfc_set_sym_referenced (gfc_symbol
* sym
)
507 if (sym
->attr
.referenced
)
510 sym
->attr
.referenced
= 1;
512 /* Remember which order dummy variables are accessed in. */
514 sym
->dummy_order
= next_dummy_order
++;
518 /* Common subroutine called by attribute changing subroutines in order
519 to prevent them from changing a symbol that has been
520 use-associated. Returns zero if it is OK to change the symbol,
524 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
527 if (attr
->use_assoc
== 0)
531 where
= &gfc_current_locus
;
534 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
537 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
544 /* Used to prevent changing the attributes of a symbol after it has been
545 used. This check is only done for dummy variables as only these can be
546 used in specification expressions. Applying this to all symbols causes
547 an error when we reach the body of a contained function. */
550 check_done (symbol_attribute
* attr
, locus
* where
)
553 if (!(attr
->dummy
&& attr
->referenced
))
557 where
= &gfc_current_locus
;
559 gfc_error ("Cannot change attributes of symbol at %L"
560 " after it has been used", where
);
566 /* Generate an error because of a duplicate attribute. */
569 duplicate_attr (const char *attr
, locus
* where
)
573 where
= &gfc_current_locus
;
575 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
580 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
583 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
586 if (attr
->allocatable
)
588 duplicate_attr ("ALLOCATABLE", where
);
592 attr
->allocatable
= 1;
593 return check_conflict (attr
, NULL
, where
);
598 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
601 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
606 duplicate_attr ("DIMENSION", where
);
611 return check_conflict (attr
, name
, where
);
616 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
619 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
624 duplicate_attr ("EXTERNAL", where
);
630 return check_conflict (attr
, NULL
, where
);
635 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
638 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
643 duplicate_attr ("INTRINSIC", where
);
649 return check_conflict (attr
, NULL
, where
);
654 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
657 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
662 duplicate_attr ("OPTIONAL", where
);
667 return check_conflict (attr
, NULL
, where
);
672 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
675 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
679 return check_conflict (attr
, NULL
, where
);
684 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
687 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
690 attr
->cray_pointer
= 1;
691 return check_conflict (attr
, NULL
, where
);
696 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
699 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
702 if (attr
->cray_pointee
)
704 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
705 " statements.", where
);
709 attr
->cray_pointee
= 1;
710 return check_conflict (attr
, NULL
, where
);
715 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
718 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
722 return check_conflict (attr
, name
, where
);
727 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
730 if (check_used (attr
, name
, where
))
736 ("SAVE attribute at %L cannot be specified in a PURE procedure",
743 if (gfc_notify_std (GFC_STD_LEGACY
,
744 "Duplicate SAVE attribute specified at %L",
751 return check_conflict (attr
, name
, where
);
756 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
759 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
764 duplicate_attr ("TARGET", where
);
769 return check_conflict (attr
, NULL
, where
);
774 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
777 if (check_used (attr
, name
, where
))
780 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
782 return check_conflict (attr
, name
, where
);
787 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
790 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
793 /* Duplicate attribute already checked for. */
795 if (check_conflict (attr
, name
, where
) == FAILURE
)
798 if (attr
->flavor
== FL_VARIABLE
)
801 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
805 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
808 /* Duplicate attribute already checked for. */
809 attr
->in_equivalence
= 1;
810 if (check_conflict (attr
, name
, where
) == FAILURE
)
813 if (attr
->flavor
== FL_VARIABLE
)
816 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
821 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
824 if (check_used (attr
, name
, where
))
828 return check_conflict (attr
, name
, where
);
833 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
837 attr
->in_namelist
= 1;
838 return check_conflict (attr
, name
, where
);
843 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
846 if (check_used (attr
, name
, where
))
850 return check_conflict (attr
, name
, where
);
855 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
858 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
862 return check_conflict (attr
, NULL
, where
);
867 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
870 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
874 return check_conflict (attr
, NULL
, where
);
879 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
882 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
886 return check_conflict (attr
, NULL
, where
);
891 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
894 if (check_used (attr
, name
, where
))
899 duplicate_attr ("ENTRY", where
);
904 return check_conflict (attr
, name
, where
);
909 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
912 if (attr
->flavor
!= FL_PROCEDURE
913 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
917 return check_conflict (attr
, name
, where
);
922 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
925 if (attr
->flavor
!= FL_PROCEDURE
926 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
929 attr
->subroutine
= 1;
930 return check_conflict (attr
, name
, where
);
935 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
938 if (attr
->flavor
!= FL_PROCEDURE
939 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
943 return check_conflict (attr
, name
, where
);
947 /* Flavors are special because some flavors are not what Fortran
948 considers attributes and can be reaffirmed multiple times. */
951 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
955 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
956 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
957 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
960 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
963 if (attr
->flavor
!= FL_UNKNOWN
)
966 where
= &gfc_current_locus
;
968 gfc_error ("%s attribute conflicts with %s attribute at %L",
969 gfc_code2string (flavors
, attr
->flavor
),
970 gfc_code2string (flavors
, f
), where
);
977 return check_conflict (attr
, name
, where
);
982 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
983 const char *name
, locus
* where
)
986 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
989 if (attr
->flavor
!= FL_PROCEDURE
990 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
994 where
= &gfc_current_locus
;
996 if (attr
->proc
!= PROC_UNKNOWN
)
998 gfc_error ("%s procedure at %L is already declared as %s procedure",
999 gfc_code2string (procedures
, t
), where
,
1000 gfc_code2string (procedures
, attr
->proc
));
1007 /* Statement functions are always scalar and functions. */
1008 if (t
== PROC_ST_FUNCTION
1009 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1010 || attr
->dimension
))
1013 return check_conflict (attr
, name
, where
);
1018 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1021 if (check_used (attr
, NULL
, where
))
1024 if (attr
->intent
== INTENT_UNKNOWN
)
1026 attr
->intent
= intent
;
1027 return check_conflict (attr
, NULL
, where
);
1031 where
= &gfc_current_locus
;
1033 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1034 gfc_intent_string (attr
->intent
),
1035 gfc_intent_string (intent
), where
);
1041 /* No checks for use-association in public and private statements. */
1044 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1045 const char *name
, locus
* where
)
1048 if (attr
->access
== ACCESS_UNKNOWN
)
1050 attr
->access
= access
;
1051 return check_conflict (attr
, name
, where
);
1055 where
= &gfc_current_locus
;
1056 gfc_error ("ACCESS specification at %L was already specified", where
);
1063 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1064 gfc_formal_arglist
* formal
, locus
* where
)
1067 if (check_used (&sym
->attr
, sym
->name
, where
))
1071 where
= &gfc_current_locus
;
1073 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1074 && sym
->attr
.if_source
!= IFSRC_DECL
)
1076 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1081 sym
->formal
= formal
;
1082 sym
->attr
.if_source
= source
;
1088 /* Add a type to a symbol. */
1091 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1095 /* TODO: This is legal if it is reaffirming an implicit type.
1096 if (check_done (&sym->attr, where))
1100 where
= &gfc_current_locus
;
1102 if (sym
->ts
.type
!= BT_UNKNOWN
)
1104 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1105 where
, gfc_basic_typename (sym
->ts
.type
));
1109 flavor
= sym
->attr
.flavor
;
1111 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1112 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1113 && sym
->attr
.subroutine
)
1114 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1116 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1125 /* Clears all attributes. */
1128 gfc_clear_attr (symbol_attribute
* attr
)
1130 memset (attr
, 0, sizeof(symbol_attribute
));
1134 /* Check for missing attributes in the new symbol. Currently does
1135 nothing, but it's not clear that it is unnecessary yet. */
1138 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1139 locus
* where ATTRIBUTE_UNUSED
)
1146 /* Copy an attribute to a symbol attribute, bit by bit. Some
1147 attributes have a lot of side-effects but cannot be present given
1148 where we are called from, so we ignore some bits. */
1151 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1154 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1157 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1159 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1161 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1163 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1165 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1167 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1169 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1174 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1177 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1180 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1182 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1184 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1187 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1189 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1191 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1193 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1196 if (src
->flavor
!= FL_UNKNOWN
1197 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1200 if (src
->intent
!= INTENT_UNKNOWN
1201 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1204 if (src
->access
!= ACCESS_UNKNOWN
1205 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1208 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1211 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1213 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1216 /* The subroutines that set these bits also cause flavors to be set,
1217 and that has already happened in the original, so don't let it
1222 dest
->intrinsic
= 1;
1231 /************** Component name management ************/
1233 /* Component names of a derived type form their own little namespaces
1234 that are separate from all other spaces. The space is composed of
1235 a singly linked list of gfc_component structures whose head is
1236 located in the parent symbol. */
1239 /* Add a component name to a symbol. The call fails if the name is
1240 already present. On success, the component pointer is modified to
1241 point to the additional component structure. */
1244 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1246 gfc_component
*p
, *tail
;
1250 for (p
= sym
->components
; p
; p
= p
->next
)
1252 if (strcmp (p
->name
, name
) == 0)
1254 gfc_error ("Component '%s' at %C already declared at %L",
1262 /* Allocate a new component. */
1263 p
= gfc_get_component ();
1266 sym
->components
= p
;
1270 p
->name
= gfc_get_string (name
);
1271 p
->loc
= gfc_current_locus
;
1278 /* Recursive function to switch derived types of all symbol in a
1282 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1290 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1291 sym
->ts
.derived
= to
;
1293 switch_types (st
->left
, from
, to
);
1294 switch_types (st
->right
, from
, to
);
1298 /* This subroutine is called when a derived type is used in order to
1299 make the final determination about which version to use. The
1300 standard requires that a type be defined before it is 'used', but
1301 such types can appear in IMPLICIT statements before the actual
1302 definition. 'Using' in this context means declaring a variable to
1303 be that type or using the type constructor.
1305 If a type is used and the components haven't been defined, then we
1306 have to have a derived type in a parent unit. We find the node in
1307 the other namespace and point the symtree node in this namespace to
1308 that node. Further reference to this name point to the correct
1309 node. If we can't find the node in a parent namespace, then we have
1312 This subroutine takes a pointer to a symbol node and returns a
1313 pointer to the translated node or NULL for an error. Usually there
1314 is no translation and we return the node we were passed. */
1317 gfc_use_derived (gfc_symbol
* sym
)
1324 if (sym
->components
!= NULL
)
1325 return sym
; /* Already defined. */
1327 if (sym
->ns
->parent
== NULL
)
1330 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1332 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1336 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1339 /* Get rid of symbol sym, translating all references to s. */
1340 for (i
= 0; i
< GFC_LETTERS
; i
++)
1342 t
= &sym
->ns
->default_type
[i
];
1343 if (t
->derived
== sym
)
1347 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1352 /* Unlink from list of modified symbols. */
1353 if (changed_syms
== sym
)
1354 changed_syms
= sym
->tlink
;
1356 for (p
= changed_syms
; p
; p
= p
->tlink
)
1357 if (p
->tlink
== sym
)
1359 p
->tlink
= sym
->tlink
;
1363 switch_types (sym
->ns
->sym_root
, sym
, s
);
1365 /* TODO: Also have to replace sym -> s in other lists like
1366 namelists, common lists and interface lists. */
1367 gfc_free_symbol (sym
);
1372 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1378 /* Given a derived type node and a component name, try to locate the
1379 component structure. Returns the NULL pointer if the component is
1380 not found or the components are private. */
1383 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1390 sym
= gfc_use_derived (sym
);
1395 for (p
= sym
->components
; p
; p
= p
->next
)
1396 if (strcmp (p
->name
, name
) == 0)
1400 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1404 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1406 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1416 /* Given a symbol, free all of the component structures and everything
1420 free_components (gfc_component
* p
)
1428 gfc_free_array_spec (p
->as
);
1429 gfc_free_expr (p
->initializer
);
1436 /* Set component attributes from a standard symbol attribute
1440 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1443 c
->dimension
= attr
->dimension
;
1444 c
->pointer
= attr
->pointer
;
1448 /* Get a standard symbol attribute structure given the component
1452 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1455 gfc_clear_attr (attr
);
1456 attr
->dimension
= c
->dimension
;
1457 attr
->pointer
= c
->pointer
;
1461 /******************** Statement label management ********************/
1463 /* Free a single gfc_st_label structure, making sure the list is not
1464 messed up. This function is called only when some parse error
1468 gfc_free_st_label (gfc_st_label
* l
)
1475 (l
->prev
->next
= l
->next
);
1478 (l
->next
->prev
= l
->prev
);
1480 if (l
->format
!= NULL
)
1481 gfc_free_expr (l
->format
);
1485 /* Free a whole list of gfc_st_label structures. */
1488 free_st_labels (gfc_st_label
* l1
)
1495 if (l1
->format
!= NULL
)
1496 gfc_free_expr (l1
->format
);
1502 /* Given a label number, search for and return a pointer to the label
1503 structure, creating it if it does not exist. */
1506 gfc_get_st_label (int labelno
)
1510 /* First see if the label is already in this namespace. */
1511 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1512 if (lp
->value
== labelno
)
1517 lp
= gfc_getmem (sizeof (gfc_st_label
));
1519 lp
->value
= labelno
;
1520 lp
->defined
= ST_LABEL_UNKNOWN
;
1521 lp
->referenced
= ST_LABEL_UNKNOWN
;
1524 lp
->next
= gfc_current_ns
->st_labels
;
1525 if (gfc_current_ns
->st_labels
)
1526 gfc_current_ns
->st_labels
->prev
= lp
;
1527 gfc_current_ns
->st_labels
= lp
;
1533 /* Called when a statement with a statement label is about to be
1534 accepted. We add the label to the list of the current namespace,
1535 making sure it hasn't been defined previously and referenced
1539 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1543 labelno
= lp
->value
;
1545 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1546 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1547 &lp
->where
, label_locus
);
1550 lp
->where
= *label_locus
;
1554 case ST_LABEL_FORMAT
:
1555 if (lp
->referenced
== ST_LABEL_TARGET
)
1556 gfc_error ("Label %d at %C already referenced as branch target",
1559 lp
->defined
= ST_LABEL_FORMAT
;
1563 case ST_LABEL_TARGET
:
1564 if (lp
->referenced
== ST_LABEL_FORMAT
)
1565 gfc_error ("Label %d at %C already referenced as a format label",
1568 lp
->defined
= ST_LABEL_TARGET
;
1573 lp
->defined
= ST_LABEL_BAD_TARGET
;
1574 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1580 /* Reference a label. Given a label and its type, see if that
1581 reference is consistent with what is known about that label,
1582 updating the unknown state. Returns FAILURE if something goes
1586 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1588 gfc_sl_type label_type
;
1595 labelno
= lp
->value
;
1597 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1598 label_type
= lp
->defined
;
1601 label_type
= lp
->referenced
;
1602 lp
->where
= gfc_current_locus
;
1605 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1607 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1612 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1613 && type
== ST_LABEL_FORMAT
)
1615 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1620 lp
->referenced
= type
;
1628 /************** Symbol table management subroutines ****************/
1630 /* Basic details: Fortran 95 requires a potentially unlimited number
1631 of distinct namespaces when compiling a program unit. This case
1632 occurs during a compilation of internal subprograms because all of
1633 the internal subprograms must be read before we can start
1634 generating code for the host.
1636 Given the tricky nature of the Fortran grammar, we must be able to
1637 undo changes made to a symbol table if the current interpretation
1638 of a statement is found to be incorrect. Whenever a symbol is
1639 looked up, we make a copy of it and link to it. All of these
1640 symbols are kept in a singly linked list so that we can commit or
1641 undo the changes at a later time.
1643 A symtree may point to a symbol node outside of its namespace. In
1644 this case, that symbol has been used as a host associated variable
1645 at some previous time. */
1647 /* Allocate a new namespace structure. Copies the implicit types from
1648 PARENT if PARENT_TYPES is set. */
1651 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1655 gfc_intrinsic_op in
;
1658 ns
= gfc_getmem (sizeof (gfc_namespace
));
1659 ns
->sym_root
= NULL
;
1660 ns
->uop_root
= NULL
;
1661 ns
->default_access
= ACCESS_UNKNOWN
;
1662 ns
->parent
= parent
;
1664 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1665 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1667 /* Initialize default implicit types. */
1668 for (i
= 'a'; i
<= 'z'; i
++)
1670 ns
->set_flag
[i
- 'a'] = 0;
1671 ts
= &ns
->default_type
[i
- 'a'];
1673 if (parent_types
&& ns
->parent
!= NULL
)
1675 /* Copy parent settings */
1676 *ts
= ns
->parent
->default_type
[i
- 'a'];
1680 if (gfc_option
.flag_implicit_none
!= 0)
1686 if ('i' <= i
&& i
<= 'n')
1688 ts
->type
= BT_INTEGER
;
1689 ts
->kind
= gfc_default_integer_kind
;
1694 ts
->kind
= gfc_default_real_kind
;
1704 /* Comparison function for symtree nodes. */
1707 compare_symtree (void * _st1
, void * _st2
)
1709 gfc_symtree
*st1
, *st2
;
1711 st1
= (gfc_symtree
*) _st1
;
1712 st2
= (gfc_symtree
*) _st2
;
1714 return strcmp (st1
->name
, st2
->name
);
1718 /* Allocate a new symtree node and associate it with the new symbol. */
1721 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1725 st
= gfc_getmem (sizeof (gfc_symtree
));
1726 st
->name
= gfc_get_string (name
);
1728 gfc_insert_bbt (root
, st
, compare_symtree
);
1733 /* Delete a symbol from the tree. Does not free the symbol itself! */
1736 delete_symtree (gfc_symtree
** root
, const char *name
)
1738 gfc_symtree st
, *st0
;
1740 st0
= gfc_find_symtree (*root
, name
);
1742 st
.name
= gfc_get_string (name
);
1743 gfc_delete_bbt (root
, &st
, compare_symtree
);
1749 /* Given a root symtree node and a name, try to find the symbol within
1750 the namespace. Returns NULL if the symbol is not found. */
1753 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1759 c
= strcmp (name
, st
->name
);
1763 st
= (c
< 0) ? st
->left
: st
->right
;
1770 /* Given a name find a user operator node, creating it if it doesn't
1771 exist. These are much simpler than symbols because they can't be
1772 ambiguous with one another. */
1775 gfc_get_uop (const char *name
)
1780 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1784 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1786 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1787 uop
->name
= gfc_get_string (name
);
1788 uop
->access
= ACCESS_UNKNOWN
;
1789 uop
->ns
= gfc_current_ns
;
1795 /* Given a name find the user operator node. Returns NULL if it does
1799 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1804 ns
= gfc_current_ns
;
1806 st
= gfc_find_symtree (ns
->uop_root
, name
);
1807 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1811 /* Remove a gfc_symbol structure and everything it points to. */
1814 gfc_free_symbol (gfc_symbol
* sym
)
1820 gfc_free_array_spec (sym
->as
);
1822 free_components (sym
->components
);
1824 gfc_free_expr (sym
->value
);
1826 gfc_free_namelist (sym
->namelist
);
1828 gfc_free_namespace (sym
->formal_ns
);
1830 gfc_free_interface (sym
->generic
);
1832 gfc_free_formal_arglist (sym
->formal
);
1838 /* Allocate and initialize a new symbol node. */
1841 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1845 p
= gfc_getmem (sizeof (gfc_symbol
));
1847 gfc_clear_ts (&p
->ts
);
1848 gfc_clear_attr (&p
->attr
);
1851 p
->declared_at
= gfc_current_locus
;
1853 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1854 gfc_internal_error ("new_symbol(): Symbol name too long");
1856 p
->name
= gfc_get_string (name
);
1861 /* Generate an error if a symbol is ambiguous. */
1864 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1867 if (st
->n
.sym
->module
)
1868 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1869 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1871 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1872 "from current program unit", name
, st
->n
.sym
->name
);
1876 /* Search for a symtree starting in the current namespace, resorting to
1877 any parent namespaces if requested by a nonzero parent_flag.
1878 Returns nonzero if the name is ambiguous. */
1881 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1882 gfc_symtree
** result
)
1887 ns
= gfc_current_ns
;
1891 st
= gfc_find_symtree (ns
->sym_root
, name
);
1897 ambiguous_symbol (name
, st
);
1916 /* Same, but returns the symbol instead. */
1919 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1920 gfc_symbol
** result
)
1925 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1930 *result
= st
->n
.sym
;
1936 /* Save symbol with the information necessary to back it out. */
1939 save_symbol_data (gfc_symbol
* sym
)
1942 if (sym
->new || sym
->old_symbol
!= NULL
)
1945 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1946 *(sym
->old_symbol
) = *sym
;
1948 sym
->tlink
= changed_syms
;
1953 /* Given a name, find a symbol, or create it if it does not exist yet
1954 in the current namespace. If the symbol is found we make sure that
1957 The integer return code indicates
1959 1 The symbol name was ambiguous
1960 2 The name meant to be established was already host associated.
1962 So if the return value is nonzero, then an error was issued. */
1965 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1970 /* This doesn't usually happen during resolution. */
1972 ns
= gfc_current_ns
;
1974 /* Try to find the symbol in ns. */
1975 st
= gfc_find_symtree (ns
->sym_root
, name
);
1979 /* If not there, create a new symbol. */
1980 p
= gfc_new_symbol (name
, ns
);
1982 /* Add to the list of tentative symbols. */
1983 p
->old_symbol
= NULL
;
1984 p
->tlink
= changed_syms
;
1989 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1996 /* Make sure the existing symbol is OK. */
1999 ambiguous_symbol (name
, st
);
2005 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2007 /* Symbol is from another namespace. */
2008 gfc_error ("Symbol '%s' at %C has already been host associated",
2015 /* Copy in case this symbol is changed. */
2016 save_symbol_data (p
);
2025 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2031 i
= gfc_get_sym_tree (name
, ns
, &st
);
2036 *result
= st
->n
.sym
;
2043 /* Subroutine that searches for a symbol, creating it if it doesn't
2044 exist, but tries to host-associate the symbol if possible. */
2047 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2052 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2055 save_symbol_data (st
->n
.sym
);
2061 if (gfc_current_ns
->parent
!= NULL
)
2063 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2074 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2079 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2084 i
= gfc_get_ha_sym_tree (name
, &st
);
2087 *result
= st
->n
.sym
;
2094 /* Return true if both symbols could refer to the same data object. Does
2095 not take account of aliasing due to equivalence statements. */
2098 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2100 /* Aliasing isn't possible if the symbols have different base types. */
2101 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2104 /* Pointers can point to other pointers, target objects and allocatable
2105 objects. Two allocatable objects cannot share the same storage. */
2106 if (lsym
->attr
.pointer
2107 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2109 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2111 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2118 /* Undoes all the changes made to symbols in the current statement.
2119 This subroutine is made simpler due to the fact that attributes are
2120 never removed once added. */
2123 gfc_undo_symbols (void)
2125 gfc_symbol
*p
, *q
, *old
;
2127 for (p
= changed_syms
; p
; p
= q
)
2133 /* Symbol was new. */
2134 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2138 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2140 gfc_free_symbol (p
);
2144 /* Restore previous state of symbol. Just copy simple stuff. */
2146 old
= p
->old_symbol
;
2148 p
->ts
.type
= old
->ts
.type
;
2149 p
->ts
.kind
= old
->ts
.kind
;
2151 p
->attr
= old
->attr
;
2153 if (p
->value
!= old
->value
)
2155 gfc_free_expr (old
->value
);
2159 if (p
->as
!= old
->as
)
2162 gfc_free_array_spec (p
->as
);
2166 p
->generic
= old
->generic
;
2167 p
->component_access
= old
->component_access
;
2169 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2171 gfc_free_namelist (p
->namelist
);
2177 if (p
->namelist_tail
!= old
->namelist_tail
)
2179 gfc_free_namelist (old
->namelist_tail
);
2180 old
->namelist_tail
->next
= NULL
;
2184 p
->namelist_tail
= old
->namelist_tail
;
2186 if (p
->formal
!= old
->formal
)
2188 gfc_free_formal_arglist (p
->formal
);
2189 p
->formal
= old
->formal
;
2192 gfc_free (p
->old_symbol
);
2193 p
->old_symbol
= NULL
;
2197 changed_syms
= NULL
;
2201 /* Makes the changes made in the current statement permanent-- gets
2202 rid of undo information. */
2205 gfc_commit_symbols (void)
2209 for (p
= changed_syms
; p
; p
= q
)
2216 if (p
->old_symbol
!= NULL
)
2218 gfc_free (p
->old_symbol
);
2219 p
->old_symbol
= NULL
;
2223 changed_syms
= NULL
;
2227 /* Recursive function that deletes an entire tree and all the common
2228 head structures it points to. */
2231 free_common_tree (gfc_symtree
* common_tree
)
2233 if (common_tree
== NULL
)
2236 free_common_tree (common_tree
->left
);
2237 free_common_tree (common_tree
->right
);
2239 gfc_free (common_tree
);
2243 /* Recursive function that deletes an entire tree and all the user
2244 operator nodes that it contains. */
2247 free_uop_tree (gfc_symtree
* uop_tree
)
2250 if (uop_tree
== NULL
)
2253 free_uop_tree (uop_tree
->left
);
2254 free_uop_tree (uop_tree
->right
);
2256 gfc_free_interface (uop_tree
->n
.uop
->operator);
2258 gfc_free (uop_tree
->n
.uop
);
2259 gfc_free (uop_tree
);
2263 /* Recursive function that deletes an entire tree and all the symbols
2264 that it contains. */
2267 free_sym_tree (gfc_symtree
* sym_tree
)
2272 if (sym_tree
== NULL
)
2275 free_sym_tree (sym_tree
->left
);
2276 free_sym_tree (sym_tree
->right
);
2278 sym
= sym_tree
->n
.sym
;
2282 gfc_internal_error ("free_sym_tree(): Negative refs");
2284 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2286 /* As formal_ns contains a reference to sym, delete formal_ns just
2287 before the deletion of sym. */
2288 ns
= sym
->formal_ns
;
2289 sym
->formal_ns
= NULL
;
2290 gfc_free_namespace (ns
);
2292 else if (sym
->refs
== 0)
2294 /* Go ahead and delete the symbol. */
2295 gfc_free_symbol (sym
);
2298 gfc_free (sym_tree
);
2302 /* Free a namespace structure and everything below it. Interface
2303 lists associated with intrinsic operators are not freed. These are
2304 taken care of when a specific name is freed. */
2307 gfc_free_namespace (gfc_namespace
* ns
)
2309 gfc_charlen
*cl
, *cl2
;
2310 gfc_namespace
*p
, *q
;
2319 gcc_assert (ns
->refs
== 0);
2321 gfc_free_statements (ns
->code
);
2323 free_sym_tree (ns
->sym_root
);
2324 free_uop_tree (ns
->uop_root
);
2325 free_common_tree (ns
->common_root
);
2327 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2330 gfc_free_expr (cl
->length
);
2334 free_st_labels (ns
->st_labels
);
2336 gfc_free_equiv (ns
->equiv
);
2338 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2339 gfc_free_interface (ns
->operator[i
]);
2341 gfc_free_data (ns
->data
);
2345 /* Recursively free any contained namespaces. */
2351 gfc_free_namespace (q
);
2357 gfc_symbol_init_2 (void)
2360 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2365 gfc_symbol_done_2 (void)
2368 gfc_free_namespace (gfc_current_ns
);
2369 gfc_current_ns
= NULL
;
2373 /* Clear mark bits from symbol nodes associated with a symtree node. */
2376 clear_sym_mark (gfc_symtree
* st
)
2379 st
->n
.sym
->mark
= 0;
2383 /* Recursively traverse the symtree nodes. */
2386 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2392 gfc_traverse_symtree (st
->left
, func
);
2393 gfc_traverse_symtree (st
->right
, func
);
2398 /* Recursive namespace traversal function. */
2401 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2407 if (st
->n
.sym
->mark
== 0)
2408 (*func
) (st
->n
.sym
);
2409 st
->n
.sym
->mark
= 1;
2411 traverse_ns (st
->left
, func
);
2412 traverse_ns (st
->right
, func
);
2416 /* Call a given function for all symbols in the namespace. We take
2417 care that each gfc_symbol node is called exactly once. */
2420 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2423 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2425 traverse_ns (ns
->sym_root
, func
);
2429 /* Return TRUE if the symbol is an automatic variable. */
2431 gfc_is_var_automatic (gfc_symbol
* sym
)
2433 /* Pointer and allocatable variables are never automatic. */
2434 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2436 /* Check for arrays with non-constant size. */
2437 if (sym
->attr
.dimension
&& sym
->as
2438 && !gfc_is_compile_time_shape (sym
->as
))
2440 /* Check for non-constant length character variables. */
2441 if (sym
->ts
.type
== BT_CHARACTER
2443 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2448 /* Given a symbol, mark it as SAVEd if it is allowed. */
2451 save_symbol (gfc_symbol
* sym
)
2454 if (sym
->attr
.use_assoc
)
2457 if (sym
->attr
.in_common
2459 || sym
->attr
.flavor
!= FL_VARIABLE
)
2461 /* Automatic objects are not saved. */
2462 if (gfc_is_var_automatic (sym
))
2464 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2468 /* Mark those symbols which can be SAVEd as such. */
2471 gfc_save_all (gfc_namespace
* ns
)
2474 gfc_traverse_ns (ns
, save_symbol
);
2479 /* Make sure that no changes to symbols are pending. */
2482 gfc_symbol_state(void) {
2484 if (changed_syms
!= NULL
)
2485 gfc_internal_error("Symbol changes still pending!");
2490 /************** Global symbol handling ************/
2493 /* Search a tree for the global symbol. */
2496 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2502 if (strcmp (symbol
->name
, name
) == 0)
2505 s
= gfc_find_gsymbol (symbol
->left
, name
);
2509 s
= gfc_find_gsymbol (symbol
->right
, name
);
2517 /* Compare two global symbols. Used for managing the BB tree. */
2520 gsym_compare (void * _s1
, void * _s2
)
2522 gfc_gsymbol
*s1
, *s2
;
2524 s1
= (gfc_gsymbol
*)_s1
;
2525 s2
= (gfc_gsymbol
*)_s2
;
2526 return strcmp(s1
->name
, s2
->name
);
2530 /* Get a global symbol, creating it if it doesn't exist. */
2533 gfc_get_gsymbol (const char *name
)
2537 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2541 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2542 s
->type
= GSYM_UNKNOWN
;
2543 s
->name
= gfc_get_string (name
);
2545 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);