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";
271 where
= &gfc_current_locus
;
273 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
280 /* Check for attributes not allowed in a BLOCK DATA. */
281 if (gfc_current_state () == COMP_BLOCK_DATA
)
285 if (attr
->allocatable
)
291 if (attr
->access
== ACCESS_PRIVATE
)
293 if (attr
->access
== ACCESS_PUBLIC
)
295 if (attr
->intent
!= INTENT_UNKNOWN
)
301 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
308 conf (pointer
, target
);
309 conf (pointer
, external
);
310 conf (pointer
, intrinsic
);
311 conf (target
, external
);
312 conf (target
, intrinsic
);
313 conf (external
, dimension
); /* See Fortran 95's R504. */
315 conf (external
, intrinsic
);
316 conf (allocatable
, pointer
);
317 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
318 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
319 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
320 conf (elemental
, recursive
);
322 conf (in_common
, dummy
);
323 conf (in_common
, allocatable
);
324 conf (in_common
, result
);
325 conf (dummy
, result
);
327 conf (in_equivalence
, use_assoc
);
328 conf (in_equivalence
, dummy
);
329 conf (in_equivalence
, target
);
330 conf (in_equivalence
, pointer
);
331 conf (in_equivalence
, function
);
332 conf (in_equivalence
, result
);
333 conf (in_equivalence
, entry
);
334 conf (in_equivalence
, allocatable
);
336 conf (in_namelist
, pointer
);
337 conf (in_namelist
, allocatable
);
339 conf (entry
, result
);
341 conf (function
, subroutine
);
343 a1
= gfc_code2string (flavors
, attr
->flavor
);
345 if (attr
->in_namelist
346 && attr
->flavor
!= FL_VARIABLE
347 && attr
->flavor
!= FL_UNKNOWN
)
354 switch (attr
->flavor
)
381 if (attr
->subroutine
)
394 case PROC_ST_FUNCTION
:
428 if (attr
->intent
!= INTENT_UNKNOWN
)
458 gfc_error ("%s attribute conflicts with %s attribute at %L",
461 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
462 a1
, a2
, name
, where
);
471 /* Mark a symbol as referenced. */
474 gfc_set_sym_referenced (gfc_symbol
* sym
)
476 if (sym
->attr
.referenced
)
479 sym
->attr
.referenced
= 1;
481 /* Remember which order dummy variables are accessed in. */
483 sym
->dummy_order
= next_dummy_order
++;
487 /* Common subroutine called by attribute changing subroutines in order
488 to prevent them from changing a symbol that has been
489 use-associated. Returns zero if it is OK to change the symbol,
493 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
496 if (attr
->use_assoc
== 0)
500 where
= &gfc_current_locus
;
503 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
506 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
513 /* Used to prevent changing the attributes of a symbol after it has been
514 used. This check is only done for dummy variables as only these can be
515 used in specification expressions. Applying this to all symbols causes
516 an error when we reach the body of a contained function. */
519 check_done (symbol_attribute
* attr
, locus
* where
)
522 if (!(attr
->dummy
&& attr
->referenced
))
526 where
= &gfc_current_locus
;
528 gfc_error ("Cannot change attributes of symbol at %L"
529 " after it has been used", where
);
535 /* Generate an error because of a duplicate attribute. */
538 duplicate_attr (const char *attr
, locus
* where
)
542 where
= &gfc_current_locus
;
544 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
549 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
552 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
555 if (attr
->allocatable
)
557 duplicate_attr ("ALLOCATABLE", where
);
561 attr
->allocatable
= 1;
562 return check_conflict (attr
, NULL
, where
);
567 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
570 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
575 duplicate_attr ("DIMENSION", where
);
580 return check_conflict (attr
, name
, where
);
585 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
588 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
593 duplicate_attr ("EXTERNAL", where
);
599 return check_conflict (attr
, NULL
, where
);
604 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
607 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
612 duplicate_attr ("INTRINSIC", where
);
618 return check_conflict (attr
, NULL
, where
);
623 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
626 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
631 duplicate_attr ("OPTIONAL", where
);
636 return check_conflict (attr
, NULL
, where
);
641 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
644 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
648 return check_conflict (attr
, NULL
, where
);
653 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
656 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
660 return check_conflict (attr
, name
, where
);
665 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
668 if (check_used (attr
, name
, where
))
674 ("SAVE attribute at %L cannot be specified in a PURE procedure",
681 duplicate_attr ("SAVE", where
);
686 return check_conflict (attr
, name
, where
);
691 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
694 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
699 duplicate_attr ("TARGET", where
);
704 return check_conflict (attr
, NULL
, where
);
709 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
712 if (check_used (attr
, name
, where
))
715 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
717 return check_conflict (attr
, name
, where
);
722 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
725 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
728 /* Duplicate attribute already checked for. */
730 if (check_conflict (attr
, name
, where
) == FAILURE
)
733 if (attr
->flavor
== FL_VARIABLE
)
736 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
740 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
743 /* Duplicate attribute already checked for. */
744 attr
->in_equivalence
= 1;
745 if (check_conflict (attr
, name
, where
) == FAILURE
)
748 if (attr
->flavor
== FL_VARIABLE
)
751 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
756 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
759 if (check_used (attr
, name
, where
))
763 return check_conflict (attr
, name
, where
);
768 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
772 attr
->in_namelist
= 1;
773 return check_conflict (attr
, name
, where
);
778 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
781 if (check_used (attr
, name
, where
))
785 return check_conflict (attr
, name
, where
);
790 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
793 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
797 return check_conflict (attr
, NULL
, where
);
802 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
805 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
809 return check_conflict (attr
, NULL
, where
);
814 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
817 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
821 return check_conflict (attr
, NULL
, where
);
826 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
829 if (check_used (attr
, name
, where
))
834 duplicate_attr ("ENTRY", where
);
839 return check_conflict (attr
, name
, where
);
844 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
847 if (attr
->flavor
!= FL_PROCEDURE
848 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
852 return check_conflict (attr
, name
, where
);
857 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
860 if (attr
->flavor
!= FL_PROCEDURE
861 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
864 attr
->subroutine
= 1;
865 return check_conflict (attr
, name
, where
);
870 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
873 if (attr
->flavor
!= FL_PROCEDURE
874 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
878 return check_conflict (attr
, name
, where
);
882 /* Flavors are special because some flavors are not what Fortran
883 considers attributes and can be reaffirmed multiple times. */
886 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
890 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
891 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
892 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
895 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
898 if (attr
->flavor
!= FL_UNKNOWN
)
901 where
= &gfc_current_locus
;
903 gfc_error ("%s attribute conflicts with %s attribute at %L",
904 gfc_code2string (flavors
, attr
->flavor
),
905 gfc_code2string (flavors
, f
), where
);
912 return check_conflict (attr
, name
, where
);
917 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
918 const char *name
, locus
* where
)
921 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
924 if (attr
->flavor
!= FL_PROCEDURE
925 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
929 where
= &gfc_current_locus
;
931 if (attr
->proc
!= PROC_UNKNOWN
)
933 gfc_error ("%s procedure at %L is already declared as %s procedure",
934 gfc_code2string (procedures
, t
), where
,
935 gfc_code2string (procedures
, attr
->proc
));
942 /* Statement functions are always scalar and functions. */
943 if (t
== PROC_ST_FUNCTION
944 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
948 return check_conflict (attr
, name
, where
);
953 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
956 if (check_used (attr
, NULL
, where
))
959 if (attr
->intent
== INTENT_UNKNOWN
)
961 attr
->intent
= intent
;
962 return check_conflict (attr
, NULL
, where
);
966 where
= &gfc_current_locus
;
968 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
969 gfc_intent_string (attr
->intent
),
970 gfc_intent_string (intent
), where
);
976 /* No checks for use-association in public and private statements. */
979 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
980 const char *name
, locus
* where
)
983 if (attr
->access
== ACCESS_UNKNOWN
)
985 attr
->access
= access
;
986 return check_conflict (attr
, name
, where
);
990 where
= &gfc_current_locus
;
991 gfc_error ("ACCESS specification at %L was already specified", where
);
998 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
999 gfc_formal_arglist
* formal
, locus
* where
)
1002 if (check_used (&sym
->attr
, sym
->name
, where
))
1006 where
= &gfc_current_locus
;
1008 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1009 && sym
->attr
.if_source
!= IFSRC_DECL
)
1011 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1016 sym
->formal
= formal
;
1017 sym
->attr
.if_source
= source
;
1023 /* Add a type to a symbol. */
1026 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1030 /* TODO: This is legal if it is reaffirming an implicit type.
1031 if (check_done (&sym->attr, where))
1035 where
= &gfc_current_locus
;
1037 if (sym
->ts
.type
!= BT_UNKNOWN
)
1039 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1040 where
, gfc_basic_typename (sym
->ts
.type
));
1044 flavor
= sym
->attr
.flavor
;
1046 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1047 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1048 && sym
->attr
.subroutine
)
1049 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1051 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1060 /* Clears all attributes. */
1063 gfc_clear_attr (symbol_attribute
* attr
)
1065 memset (attr
, 0, sizeof(symbol_attribute
));
1069 /* Check for missing attributes in the new symbol. Currently does
1070 nothing, but it's not clear that it is unnecessary yet. */
1073 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1074 locus
* where ATTRIBUTE_UNUSED
)
1081 /* Copy an attribute to a symbol attribute, bit by bit. Some
1082 attributes have a lot of side-effects but cannot be present given
1083 where we are called from, so we ignore some bits. */
1086 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1089 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1092 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1094 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1096 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1098 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1100 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1102 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1104 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1109 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1112 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1115 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1117 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1119 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1122 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1124 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1126 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1128 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1131 if (src
->flavor
!= FL_UNKNOWN
1132 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1135 if (src
->intent
!= INTENT_UNKNOWN
1136 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1139 if (src
->access
!= ACCESS_UNKNOWN
1140 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1143 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1146 /* The subroutines that set these bits also cause flavors to be set,
1147 and that has already happened in the original, so don't let it
1152 dest
->intrinsic
= 1;
1161 /************** Component name management ************/
1163 /* Component names of a derived type form their own little namespaces
1164 that are separate from all other spaces. The space is composed of
1165 a singly linked list of gfc_component structures whose head is
1166 located in the parent symbol. */
1169 /* Add a component name to a symbol. The call fails if the name is
1170 already present. On success, the component pointer is modified to
1171 point to the additional component structure. */
1174 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1176 gfc_component
*p
, *tail
;
1180 for (p
= sym
->components
; p
; p
= p
->next
)
1182 if (strcmp (p
->name
, name
) == 0)
1184 gfc_error ("Component '%s' at %C already declared at %L",
1192 /* Allocate a new component. */
1193 p
= gfc_get_component ();
1196 sym
->components
= p
;
1200 p
->name
= gfc_get_string (name
);
1201 p
->loc
= gfc_current_locus
;
1208 /* Recursive function to switch derived types of all symbol in a
1212 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1220 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1221 sym
->ts
.derived
= to
;
1223 switch_types (st
->left
, from
, to
);
1224 switch_types (st
->right
, from
, to
);
1228 /* This subroutine is called when a derived type is used in order to
1229 make the final determination about which version to use. The
1230 standard requires that a type be defined before it is 'used', but
1231 such types can appear in IMPLICIT statements before the actual
1232 definition. 'Using' in this context means declaring a variable to
1233 be that type or using the type constructor.
1235 If a type is used and the components haven't been defined, then we
1236 have to have a derived type in a parent unit. We find the node in
1237 the other namespace and point the symtree node in this namespace to
1238 that node. Further reference to this name point to the correct
1239 node. If we can't find the node in a parent namespace, then we have
1242 This subroutine takes a pointer to a symbol node and returns a
1243 pointer to the translated node or NULL for an error. Usually there
1244 is no translation and we return the node we were passed. */
1247 gfc_use_derived (gfc_symbol
* sym
)
1254 if (sym
->components
!= NULL
)
1255 return sym
; /* Already defined. */
1257 if (sym
->ns
->parent
== NULL
)
1260 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1262 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1266 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1269 /* Get rid of symbol sym, translating all references to s. */
1270 for (i
= 0; i
< GFC_LETTERS
; i
++)
1272 t
= &sym
->ns
->default_type
[i
];
1273 if (t
->derived
== sym
)
1277 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1282 /* Unlink from list of modified symbols. */
1283 if (changed_syms
== sym
)
1284 changed_syms
= sym
->tlink
;
1286 for (p
= changed_syms
; p
; p
= p
->tlink
)
1287 if (p
->tlink
== sym
)
1289 p
->tlink
= sym
->tlink
;
1293 switch_types (sym
->ns
->sym_root
, sym
, s
);
1295 /* TODO: Also have to replace sym -> s in other lists like
1296 namelists, common lists and interface lists. */
1297 gfc_free_symbol (sym
);
1302 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1308 /* Given a derived type node and a component name, try to locate the
1309 component structure. Returns the NULL pointer if the component is
1310 not found or the components are private. */
1313 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1320 sym
= gfc_use_derived (sym
);
1325 for (p
= sym
->components
; p
; p
= p
->next
)
1326 if (strcmp (p
->name
, name
) == 0)
1330 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1334 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1336 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1346 /* Given a symbol, free all of the component structures and everything
1350 free_components (gfc_component
* p
)
1358 gfc_free_array_spec (p
->as
);
1359 gfc_free_expr (p
->initializer
);
1366 /* Set component attributes from a standard symbol attribute
1370 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1373 c
->dimension
= attr
->dimension
;
1374 c
->pointer
= attr
->pointer
;
1378 /* Get a standard symbol attribute structure given the component
1382 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1385 gfc_clear_attr (attr
);
1386 attr
->dimension
= c
->dimension
;
1387 attr
->pointer
= c
->pointer
;
1391 /******************** Statement label management ********************/
1393 /* Free a single gfc_st_label structure, making sure the list is not
1394 messed up. This function is called only when some parse error
1398 gfc_free_st_label (gfc_st_label
* l
)
1405 (l
->prev
->next
= l
->next
);
1408 (l
->next
->prev
= l
->prev
);
1410 if (l
->format
!= NULL
)
1411 gfc_free_expr (l
->format
);
1415 /* Free a whole list of gfc_st_label structures. */
1418 free_st_labels (gfc_st_label
* l1
)
1425 if (l1
->format
!= NULL
)
1426 gfc_free_expr (l1
->format
);
1432 /* Given a label number, search for and return a pointer to the label
1433 structure, creating it if it does not exist. */
1436 gfc_get_st_label (int labelno
)
1440 /* First see if the label is already in this namespace. */
1441 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1442 if (lp
->value
== labelno
)
1447 lp
= gfc_getmem (sizeof (gfc_st_label
));
1449 lp
->value
= labelno
;
1450 lp
->defined
= ST_LABEL_UNKNOWN
;
1451 lp
->referenced
= ST_LABEL_UNKNOWN
;
1454 lp
->next
= gfc_current_ns
->st_labels
;
1455 if (gfc_current_ns
->st_labels
)
1456 gfc_current_ns
->st_labels
->prev
= lp
;
1457 gfc_current_ns
->st_labels
= lp
;
1463 /* Called when a statement with a statement label is about to be
1464 accepted. We add the label to the list of the current namespace,
1465 making sure it hasn't been defined previously and referenced
1469 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1473 labelno
= lp
->value
;
1475 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1476 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1477 &lp
->where
, label_locus
);
1480 lp
->where
= *label_locus
;
1484 case ST_LABEL_FORMAT
:
1485 if (lp
->referenced
== ST_LABEL_TARGET
)
1486 gfc_error ("Label %d at %C already referenced as branch target",
1489 lp
->defined
= ST_LABEL_FORMAT
;
1493 case ST_LABEL_TARGET
:
1494 if (lp
->referenced
== ST_LABEL_FORMAT
)
1495 gfc_error ("Label %d at %C already referenced as a format label",
1498 lp
->defined
= ST_LABEL_TARGET
;
1503 lp
->defined
= ST_LABEL_BAD_TARGET
;
1504 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1510 /* Reference a label. Given a label and its type, see if that
1511 reference is consistent with what is known about that label,
1512 updating the unknown state. Returns FAILURE if something goes
1516 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1518 gfc_sl_type label_type
;
1525 labelno
= lp
->value
;
1527 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1528 label_type
= lp
->defined
;
1531 label_type
= lp
->referenced
;
1532 lp
->where
= gfc_current_locus
;
1535 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1537 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1542 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1543 && type
== ST_LABEL_FORMAT
)
1545 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1550 lp
->referenced
= type
;
1558 /************** Symbol table management subroutines ****************/
1560 /* Basic details: Fortran 95 requires a potentially unlimited number
1561 of distinct namespaces when compiling a program unit. This case
1562 occurs during a compilation of internal subprograms because all of
1563 the internal subprograms must be read before we can start
1564 generating code for the host.
1566 Given the tricky nature of the Fortran grammar, we must be able to
1567 undo changes made to a symbol table if the current interpretation
1568 of a statement is found to be incorrect. Whenever a symbol is
1569 looked up, we make a copy of it and link to it. All of these
1570 symbols are kept in a singly linked list so that we can commit or
1571 undo the changes at a later time.
1573 A symtree may point to a symbol node outside of its namespace. In
1574 this case, that symbol has been used as a host associated variable
1575 at some previous time. */
1577 /* Allocate a new namespace structure. Copies the implicit types from
1578 PARENT if PARENT_TYPES is set. */
1581 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1585 gfc_intrinsic_op in
;
1588 ns
= gfc_getmem (sizeof (gfc_namespace
));
1589 ns
->sym_root
= NULL
;
1590 ns
->uop_root
= NULL
;
1591 ns
->default_access
= ACCESS_UNKNOWN
;
1592 ns
->parent
= parent
;
1594 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1595 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1597 /* Initialize default implicit types. */
1598 for (i
= 'a'; i
<= 'z'; i
++)
1600 ns
->set_flag
[i
- 'a'] = 0;
1601 ts
= &ns
->default_type
[i
- 'a'];
1603 if (parent_types
&& ns
->parent
!= NULL
)
1605 /* Copy parent settings */
1606 *ts
= ns
->parent
->default_type
[i
- 'a'];
1610 if (gfc_option
.flag_implicit_none
!= 0)
1616 if ('i' <= i
&& i
<= 'n')
1618 ts
->type
= BT_INTEGER
;
1619 ts
->kind
= gfc_default_integer_kind
;
1624 ts
->kind
= gfc_default_real_kind
;
1634 /* Comparison function for symtree nodes. */
1637 compare_symtree (void * _st1
, void * _st2
)
1639 gfc_symtree
*st1
, *st2
;
1641 st1
= (gfc_symtree
*) _st1
;
1642 st2
= (gfc_symtree
*) _st2
;
1644 return strcmp (st1
->name
, st2
->name
);
1648 /* Allocate a new symtree node and associate it with the new symbol. */
1651 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1655 st
= gfc_getmem (sizeof (gfc_symtree
));
1656 st
->name
= gfc_get_string (name
);
1658 gfc_insert_bbt (root
, st
, compare_symtree
);
1663 /* Delete a symbol from the tree. Does not free the symbol itself! */
1666 delete_symtree (gfc_symtree
** root
, const char *name
)
1668 gfc_symtree st
, *st0
;
1670 st0
= gfc_find_symtree (*root
, name
);
1672 st
.name
= gfc_get_string (name
);
1673 gfc_delete_bbt (root
, &st
, compare_symtree
);
1679 /* Given a root symtree node and a name, try to find the symbol within
1680 the namespace. Returns NULL if the symbol is not found. */
1683 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1689 c
= strcmp (name
, st
->name
);
1693 st
= (c
< 0) ? st
->left
: st
->right
;
1700 /* Given a name find a user operator node, creating it if it doesn't
1701 exist. These are much simpler than symbols because they can't be
1702 ambiguous with one another. */
1705 gfc_get_uop (const char *name
)
1710 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1714 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1716 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1717 uop
->name
= gfc_get_string (name
);
1718 uop
->access
= ACCESS_UNKNOWN
;
1719 uop
->ns
= gfc_current_ns
;
1725 /* Given a name find the user operator node. Returns NULL if it does
1729 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1734 ns
= gfc_current_ns
;
1736 st
= gfc_find_symtree (ns
->uop_root
, name
);
1737 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1741 /* Remove a gfc_symbol structure and everything it points to. */
1744 gfc_free_symbol (gfc_symbol
* sym
)
1750 gfc_free_array_spec (sym
->as
);
1752 free_components (sym
->components
);
1754 gfc_free_expr (sym
->value
);
1756 gfc_free_namelist (sym
->namelist
);
1758 gfc_free_namespace (sym
->formal_ns
);
1760 gfc_free_interface (sym
->generic
);
1762 gfc_free_formal_arglist (sym
->formal
);
1768 /* Allocate and initialize a new symbol node. */
1771 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1775 p
= gfc_getmem (sizeof (gfc_symbol
));
1777 gfc_clear_ts (&p
->ts
);
1778 gfc_clear_attr (&p
->attr
);
1781 p
->declared_at
= gfc_current_locus
;
1783 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1784 gfc_internal_error ("new_symbol(): Symbol name too long");
1786 p
->name
= gfc_get_string (name
);
1791 /* Generate an error if a symbol is ambiguous. */
1794 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1797 if (st
->n
.sym
->module
)
1798 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1799 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1801 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1802 "from current program unit", name
, st
->n
.sym
->name
);
1806 /* Search for a symtree starting in the current namespace, resorting to
1807 any parent namespaces if requested by a nonzero parent_flag.
1808 Returns nonzero if the name is ambiguous. */
1811 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1812 gfc_symtree
** result
)
1817 ns
= gfc_current_ns
;
1821 st
= gfc_find_symtree (ns
->sym_root
, name
);
1827 ambiguous_symbol (name
, st
);
1846 /* Same, but returns the symbol instead. */
1849 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1850 gfc_symbol
** result
)
1855 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1860 *result
= st
->n
.sym
;
1866 /* Save symbol with the information necessary to back it out. */
1869 save_symbol_data (gfc_symbol
* sym
)
1872 if (sym
->new || sym
->old_symbol
!= NULL
)
1875 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1876 *(sym
->old_symbol
) = *sym
;
1878 sym
->tlink
= changed_syms
;
1883 /* Given a name, find a symbol, or create it if it does not exist yet
1884 in the current namespace. If the symbol is found we make sure that
1887 The integer return code indicates
1889 1 The symbol name was ambiguous
1890 2 The name meant to be established was already host associated.
1892 So if the return value is nonzero, then an error was issued. */
1895 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1900 /* This doesn't usually happen during resolution. */
1902 ns
= gfc_current_ns
;
1904 /* Try to find the symbol in ns. */
1905 st
= gfc_find_symtree (ns
->sym_root
, name
);
1909 /* If not there, create a new symbol. */
1910 p
= gfc_new_symbol (name
, ns
);
1912 /* Add to the list of tentative symbols. */
1913 p
->old_symbol
= NULL
;
1914 p
->tlink
= changed_syms
;
1919 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1926 /* Make sure the existing symbol is OK. */
1929 ambiguous_symbol (name
, st
);
1935 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1937 /* Symbol is from another namespace. */
1938 gfc_error ("Symbol '%s' at %C has already been host associated",
1945 /* Copy in case this symbol is changed. */
1946 save_symbol_data (p
);
1955 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1961 i
= gfc_get_sym_tree (name
, ns
, &st
);
1966 *result
= st
->n
.sym
;
1973 /* Subroutine that searches for a symbol, creating it if it doesn't
1974 exist, but tries to host-associate the symbol if possible. */
1977 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
1982 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1985 save_symbol_data (st
->n
.sym
);
1991 if (gfc_current_ns
->parent
!= NULL
)
1993 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2004 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2009 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2014 i
= gfc_get_ha_sym_tree (name
, &st
);
2017 *result
= st
->n
.sym
;
2024 /* Return true if both symbols could refer to the same data object. Does
2025 not take account of aliasing due to equivalence statements. */
2028 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2030 /* Aliasing isn't possible if the symbols have different base types. */
2031 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2034 /* Pointers can point to other pointers, target objects and allocatable
2035 objects. Two allocatable objects cannot share the same storage. */
2036 if (lsym
->attr
.pointer
2037 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2039 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2041 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2048 /* Undoes all the changes made to symbols in the current statement.
2049 This subroutine is made simpler due to the fact that attributes are
2050 never removed once added. */
2053 gfc_undo_symbols (void)
2055 gfc_symbol
*p
, *q
, *old
;
2057 for (p
= changed_syms
; p
; p
= q
)
2063 /* Symbol was new. */
2064 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2068 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2070 gfc_free_symbol (p
);
2074 /* Restore previous state of symbol. Just copy simple stuff. */
2076 old
= p
->old_symbol
;
2078 p
->ts
.type
= old
->ts
.type
;
2079 p
->ts
.kind
= old
->ts
.kind
;
2081 p
->attr
= old
->attr
;
2083 if (p
->value
!= old
->value
)
2085 gfc_free_expr (old
->value
);
2089 if (p
->as
!= old
->as
)
2092 gfc_free_array_spec (p
->as
);
2096 p
->generic
= old
->generic
;
2097 p
->component_access
= old
->component_access
;
2099 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2101 gfc_free_namelist (p
->namelist
);
2107 if (p
->namelist_tail
!= old
->namelist_tail
)
2109 gfc_free_namelist (old
->namelist_tail
);
2110 old
->namelist_tail
->next
= NULL
;
2114 p
->namelist_tail
= old
->namelist_tail
;
2116 if (p
->formal
!= old
->formal
)
2118 gfc_free_formal_arglist (p
->formal
);
2119 p
->formal
= old
->formal
;
2122 gfc_free (p
->old_symbol
);
2123 p
->old_symbol
= NULL
;
2127 changed_syms
= NULL
;
2131 /* Makes the changes made in the current statement permanent-- gets
2132 rid of undo information. */
2135 gfc_commit_symbols (void)
2139 for (p
= changed_syms
; p
; p
= q
)
2146 if (p
->old_symbol
!= NULL
)
2148 gfc_free (p
->old_symbol
);
2149 p
->old_symbol
= NULL
;
2153 changed_syms
= NULL
;
2157 /* Recursive function that deletes an entire tree and all the common
2158 head structures it points to. */
2161 free_common_tree (gfc_symtree
* common_tree
)
2163 if (common_tree
== NULL
)
2166 free_common_tree (common_tree
->left
);
2167 free_common_tree (common_tree
->right
);
2169 gfc_free (common_tree
);
2173 /* Recursive function that deletes an entire tree and all the user
2174 operator nodes that it contains. */
2177 free_uop_tree (gfc_symtree
* uop_tree
)
2180 if (uop_tree
== NULL
)
2183 free_uop_tree (uop_tree
->left
);
2184 free_uop_tree (uop_tree
->right
);
2186 gfc_free_interface (uop_tree
->n
.uop
->operator);
2188 gfc_free (uop_tree
->n
.uop
);
2189 gfc_free (uop_tree
);
2193 /* Recursive function that deletes an entire tree and all the symbols
2194 that it contains. */
2197 free_sym_tree (gfc_symtree
* sym_tree
)
2202 if (sym_tree
== NULL
)
2205 free_sym_tree (sym_tree
->left
);
2206 free_sym_tree (sym_tree
->right
);
2208 sym
= sym_tree
->n
.sym
;
2212 gfc_internal_error ("free_sym_tree(): Negative refs");
2214 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2216 /* As formal_ns contains a reference to sym, delete formal_ns just
2217 before the deletion of sym. */
2218 ns
= sym
->formal_ns
;
2219 sym
->formal_ns
= NULL
;
2220 gfc_free_namespace (ns
);
2222 else if (sym
->refs
== 0)
2224 /* Go ahead and delete the symbol. */
2225 gfc_free_symbol (sym
);
2228 gfc_free (sym_tree
);
2232 /* Free a namespace structure and everything below it. Interface
2233 lists associated with intrinsic operators are not freed. These are
2234 taken care of when a specific name is freed. */
2237 gfc_free_namespace (gfc_namespace
* ns
)
2239 gfc_charlen
*cl
, *cl2
;
2240 gfc_namespace
*p
, *q
;
2249 gcc_assert (ns
->refs
== 0);
2251 gfc_free_statements (ns
->code
);
2253 free_sym_tree (ns
->sym_root
);
2254 free_uop_tree (ns
->uop_root
);
2255 free_common_tree (ns
->common_root
);
2257 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2260 gfc_free_expr (cl
->length
);
2264 free_st_labels (ns
->st_labels
);
2266 gfc_free_equiv (ns
->equiv
);
2268 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2269 gfc_free_interface (ns
->operator[i
]);
2271 gfc_free_data (ns
->data
);
2275 /* Recursively free any contained namespaces. */
2281 gfc_free_namespace (q
);
2287 gfc_symbol_init_2 (void)
2290 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2295 gfc_symbol_done_2 (void)
2298 gfc_free_namespace (gfc_current_ns
);
2299 gfc_current_ns
= NULL
;
2303 /* Clear mark bits from symbol nodes associated with a symtree node. */
2306 clear_sym_mark (gfc_symtree
* st
)
2309 st
->n
.sym
->mark
= 0;
2313 /* Recursively traverse the symtree nodes. */
2316 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2322 gfc_traverse_symtree (st
->left
, func
);
2323 gfc_traverse_symtree (st
->right
, func
);
2328 /* Recursive namespace traversal function. */
2331 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2337 if (st
->n
.sym
->mark
== 0)
2338 (*func
) (st
->n
.sym
);
2339 st
->n
.sym
->mark
= 1;
2341 traverse_ns (st
->left
, func
);
2342 traverse_ns (st
->right
, func
);
2346 /* Call a given function for all symbols in the namespace. We take
2347 care that each gfc_symbol node is called exactly once. */
2350 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2353 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2355 traverse_ns (ns
->sym_root
, func
);
2359 /* Return TRUE if the symbol is an automatic variable. */
2361 gfc_is_var_automatic (gfc_symbol
* sym
)
2363 /* Pointer and allocatable variables are never automatic. */
2364 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2366 /* Check for arrays with non-constant size. */
2367 if (sym
->attr
.dimension
&& sym
->as
2368 && !gfc_is_compile_time_shape (sym
->as
))
2370 /* Check for non-constant length character variables. */
2371 if (sym
->ts
.type
== BT_CHARACTER
2373 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2378 /* Given a symbol, mark it as SAVEd if it is allowed. */
2381 save_symbol (gfc_symbol
* sym
)
2384 if (sym
->attr
.use_assoc
)
2387 if (sym
->attr
.in_common
2389 || sym
->attr
.flavor
!= FL_VARIABLE
)
2391 /* Automatic objects are not saved. */
2392 if (gfc_is_var_automatic (sym
))
2394 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2398 /* Mark those symbols which can be SAVEd as such. */
2401 gfc_save_all (gfc_namespace
* ns
)
2404 gfc_traverse_ns (ns
, save_symbol
);
2409 /* Make sure that no changes to symbols are pending. */
2412 gfc_symbol_state(void) {
2414 if (changed_syms
!= NULL
)
2415 gfc_internal_error("Symbol changes still pending!");
2420 /************** Global symbol handling ************/
2423 /* Search a tree for the global symbol. */
2426 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2432 if (strcmp (symbol
->name
, name
) == 0)
2435 s
= gfc_find_gsymbol (symbol
->left
, name
);
2439 s
= gfc_find_gsymbol (symbol
->right
, name
);
2447 /* Compare two global symbols. Used for managing the BB tree. */
2450 gsym_compare (void * _s1
, void * _s2
)
2452 gfc_gsymbol
*s1
, *s2
;
2454 s1
= (gfc_gsymbol
*)_s1
;
2455 s2
= (gfc_gsymbol
*)_s2
;
2456 return strcmp(s1
->name
, s2
->name
);
2460 /* Get a global symbol, creating it if it doesn't exist. */
2463 gfc_get_gsymbol (const char *name
)
2467 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2471 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2472 s
->type
= GSYM_UNKNOWN
;
2473 s
->name
= gfc_get_string (name
);
2475 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);