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";
270 where
= &gfc_current_locus
;
272 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
279 /* Check for attributes not allowed in a BLOCK DATA. */
280 if (gfc_current_state () == COMP_BLOCK_DATA
)
284 if (attr
->allocatable
)
290 if (attr
->access
== ACCESS_PRIVATE
)
292 if (attr
->access
== ACCESS_PUBLIC
)
294 if (attr
->intent
!= INTENT_UNKNOWN
)
300 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
307 conf (pointer
, target
);
308 conf (pointer
, external
);
309 conf (pointer
, intrinsic
);
310 conf (target
, external
);
311 conf (target
, intrinsic
);
312 conf (external
, dimension
); /* See Fortran 95's R504. */
314 conf (external
, intrinsic
);
315 conf (allocatable
, pointer
);
316 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
317 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
318 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
319 conf (elemental
, recursive
);
321 conf (in_common
, dummy
);
322 conf (in_common
, allocatable
);
323 conf (in_common
, result
);
324 conf (dummy
, result
);
326 conf (in_namelist
, pointer
);
327 conf (in_namelist
, allocatable
);
329 conf (entry
, result
);
331 conf (function
, subroutine
);
333 a1
= gfc_code2string (flavors
, attr
->flavor
);
335 if (attr
->in_namelist
336 && attr
->flavor
!= FL_VARIABLE
337 && attr
->flavor
!= FL_UNKNOWN
)
344 switch (attr
->flavor
)
371 if (attr
->subroutine
)
384 case PROC_ST_FUNCTION
:
418 if (attr
->intent
!= INTENT_UNKNOWN
)
447 gfc_error ("%s attribute conflicts with %s attribute at %L",
450 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
451 a1
, a2
, name
, where
);
460 /* Mark a symbol as referenced. */
463 gfc_set_sym_referenced (gfc_symbol
* sym
)
465 if (sym
->attr
.referenced
)
468 sym
->attr
.referenced
= 1;
470 /* Remember which order dummy variables are accessed in. */
472 sym
->dummy_order
= next_dummy_order
++;
476 /* Common subroutine called by attribute changing subroutines in order
477 to prevent them from changing a symbol that has been
478 use-associated. Returns zero if it is OK to change the symbol,
482 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
485 if (attr
->use_assoc
== 0)
489 where
= &gfc_current_locus
;
492 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
495 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
502 /* Used to prevent changing the attributes of a symbol after it has been
503 used. This check is only done for dummy variables as only these can be
504 used in specification expressions. Applying this to all symbols causes
505 an error when we reach the body of a contained function. */
508 check_done (symbol_attribute
* attr
, locus
* where
)
511 if (!(attr
->dummy
&& attr
->referenced
))
515 where
= &gfc_current_locus
;
517 gfc_error ("Cannot change attributes of symbol at %L"
518 " after it has been used", where
);
524 /* Generate an error because of a duplicate attribute. */
527 duplicate_attr (const char *attr
, locus
* where
)
531 where
= &gfc_current_locus
;
533 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
538 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
541 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
544 if (attr
->allocatable
)
546 duplicate_attr ("ALLOCATABLE", where
);
550 attr
->allocatable
= 1;
551 return check_conflict (attr
, NULL
, where
);
556 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
559 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
564 duplicate_attr ("DIMENSION", where
);
569 return check_conflict (attr
, name
, where
);
574 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
577 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
582 duplicate_attr ("EXTERNAL", where
);
588 return check_conflict (attr
, NULL
, where
);
593 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
596 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
601 duplicate_attr ("INTRINSIC", where
);
607 return check_conflict (attr
, NULL
, where
);
612 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
615 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
620 duplicate_attr ("OPTIONAL", where
);
625 return check_conflict (attr
, NULL
, where
);
630 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
633 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
637 return check_conflict (attr
, NULL
, where
);
642 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
645 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
649 return check_conflict (attr
, name
, where
);
654 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
657 if (check_used (attr
, name
, where
))
663 ("SAVE attribute at %L cannot be specified in a PURE procedure",
670 duplicate_attr ("SAVE", where
);
675 return check_conflict (attr
, name
, where
);
680 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
683 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
688 duplicate_attr ("TARGET", where
);
693 return check_conflict (attr
, NULL
, where
);
698 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
701 if (check_used (attr
, name
, where
))
704 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
706 return check_conflict (attr
, name
, where
);
711 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
714 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
717 /* Duplicate attribute already checked for. */
719 if (check_conflict (attr
, name
, where
) == FAILURE
)
722 if (attr
->flavor
== FL_VARIABLE
)
725 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
730 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
733 if (check_used (attr
, name
, where
))
737 return check_conflict (attr
, name
, where
);
742 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
746 attr
->in_namelist
= 1;
747 return check_conflict (attr
, name
, where
);
752 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
755 if (check_used (attr
, name
, where
))
759 return check_conflict (attr
, name
, where
);
764 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
767 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
771 return check_conflict (attr
, NULL
, where
);
776 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
779 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
783 return check_conflict (attr
, NULL
, where
);
788 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
791 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
795 return check_conflict (attr
, NULL
, where
);
800 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
803 if (check_used (attr
, name
, where
))
808 duplicate_attr ("ENTRY", where
);
813 return check_conflict (attr
, name
, where
);
818 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
821 if (attr
->flavor
!= FL_PROCEDURE
822 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
826 return check_conflict (attr
, name
, where
);
831 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
834 if (attr
->flavor
!= FL_PROCEDURE
835 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
838 attr
->subroutine
= 1;
839 return check_conflict (attr
, name
, where
);
844 gfc_add_generic (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
);
856 /* Flavors are special because some flavors are not what Fortran
857 considers attributes and can be reaffirmed multiple times. */
860 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
864 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
865 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
866 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
869 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
872 if (attr
->flavor
!= FL_UNKNOWN
)
875 where
= &gfc_current_locus
;
877 gfc_error ("%s attribute conflicts with %s attribute at %L",
878 gfc_code2string (flavors
, attr
->flavor
),
879 gfc_code2string (flavors
, f
), where
);
886 return check_conflict (attr
, name
, where
);
891 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
892 const char *name
, locus
* where
)
895 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
898 if (attr
->flavor
!= FL_PROCEDURE
899 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
903 where
= &gfc_current_locus
;
905 if (attr
->proc
!= PROC_UNKNOWN
)
907 gfc_error ("%s procedure at %L is already %s %s procedure",
908 gfc_code2string (procedures
, t
), where
,
909 gfc_article (gfc_code2string (procedures
, attr
->proc
)),
910 gfc_code2string (procedures
, attr
->proc
));
917 /* Statement functions are always scalar and functions. */
918 if (t
== PROC_ST_FUNCTION
919 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
923 return check_conflict (attr
, name
, where
);
928 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
931 if (check_used (attr
, NULL
, where
))
934 if (attr
->intent
== INTENT_UNKNOWN
)
936 attr
->intent
= intent
;
937 return check_conflict (attr
, NULL
, where
);
941 where
= &gfc_current_locus
;
943 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
944 gfc_intent_string (attr
->intent
),
945 gfc_intent_string (intent
), where
);
951 /* No checks for use-association in public and private statements. */
954 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
955 const char *name
, locus
* where
)
958 if (attr
->access
== ACCESS_UNKNOWN
)
960 attr
->access
= access
;
961 return check_conflict (attr
, name
, where
);
965 where
= &gfc_current_locus
;
966 gfc_error ("ACCESS specification at %L was already specified", where
);
973 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
974 gfc_formal_arglist
* formal
, locus
* where
)
977 if (check_used (&sym
->attr
, sym
->name
, where
))
981 where
= &gfc_current_locus
;
983 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
984 && sym
->attr
.if_source
!= IFSRC_DECL
)
986 gfc_error ("Symbol '%s' at %L already has an explicit interface",
991 sym
->formal
= formal
;
992 sym
->attr
.if_source
= source
;
998 /* Add a type to a symbol. */
1001 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1005 /* TODO: This is legal if it is reaffirming an implicit type.
1006 if (check_done (&sym->attr, where))
1010 where
= &gfc_current_locus
;
1012 if (sym
->ts
.type
!= BT_UNKNOWN
)
1014 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1015 where
, gfc_basic_typename (sym
->ts
.type
));
1019 flavor
= sym
->attr
.flavor
;
1021 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1022 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1023 && sym
->attr
.subroutine
)
1024 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1026 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1035 /* Clears all attributes. */
1038 gfc_clear_attr (symbol_attribute
* attr
)
1040 memset (attr
, 0, sizeof(symbol_attribute
));
1044 /* Check for missing attributes in the new symbol. Currently does
1045 nothing, but it's not clear that it is unnecessary yet. */
1048 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1049 locus
* where ATTRIBUTE_UNUSED
)
1056 /* Copy an attribute to a symbol attribute, bit by bit. Some
1057 attributes have a lot of side-effects but cannot be present given
1058 where we are called from, so we ignore some bits. */
1061 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1064 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1067 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1069 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1071 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1073 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1075 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1077 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1079 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1084 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1087 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1090 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1092 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1094 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1097 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1099 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1101 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1103 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1106 if (src
->flavor
!= FL_UNKNOWN
1107 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1110 if (src
->intent
!= INTENT_UNKNOWN
1111 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1114 if (src
->access
!= ACCESS_UNKNOWN
1115 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1118 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1121 /* The subroutines that set these bits also cause flavors to be set,
1122 and that has already happened in the original, so don't let it
1127 dest
->intrinsic
= 1;
1136 /************** Component name management ************/
1138 /* Component names of a derived type form their own little namespaces
1139 that are separate from all other spaces. The space is composed of
1140 a singly linked list of gfc_component structures whose head is
1141 located in the parent symbol. */
1144 /* Add a component name to a symbol. The call fails if the name is
1145 already present. On success, the component pointer is modified to
1146 point to the additional component structure. */
1149 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1151 gfc_component
*p
, *tail
;
1155 for (p
= sym
->components
; p
; p
= p
->next
)
1157 if (strcmp (p
->name
, name
) == 0)
1159 gfc_error ("Component '%s' at %C already declared at %L",
1167 /* Allocate a new component. */
1168 p
= gfc_get_component ();
1171 sym
->components
= p
;
1175 p
->name
= gfc_get_string (name
);
1176 p
->loc
= gfc_current_locus
;
1183 /* Recursive function to switch derived types of all symbol in a
1187 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1195 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1196 sym
->ts
.derived
= to
;
1198 switch_types (st
->left
, from
, to
);
1199 switch_types (st
->right
, from
, to
);
1203 /* This subroutine is called when a derived type is used in order to
1204 make the final determination about which version to use. The
1205 standard requires that a type be defined before it is 'used', but
1206 such types can appear in IMPLICIT statements before the actual
1207 definition. 'Using' in this context means declaring a variable to
1208 be that type or using the type constructor.
1210 If a type is used and the components haven't been defined, then we
1211 have to have a derived type in a parent unit. We find the node in
1212 the other namespace and point the symtree node in this namespace to
1213 that node. Further reference to this name point to the correct
1214 node. If we can't find the node in a parent namespace, then we have
1217 This subroutine takes a pointer to a symbol node and returns a
1218 pointer to the translated node or NULL for an error. Usually there
1219 is no translation and we return the node we were passed. */
1222 gfc_use_derived (gfc_symbol
* sym
)
1229 if (sym
->components
!= NULL
)
1230 return sym
; /* Already defined. */
1232 if (sym
->ns
->parent
== NULL
)
1235 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1237 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1241 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1244 /* Get rid of symbol sym, translating all references to s. */
1245 for (i
= 0; i
< GFC_LETTERS
; i
++)
1247 t
= &sym
->ns
->default_type
[i
];
1248 if (t
->derived
== sym
)
1252 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1257 /* Unlink from list of modified symbols. */
1258 if (changed_syms
== sym
)
1259 changed_syms
= sym
->tlink
;
1261 for (p
= changed_syms
; p
; p
= p
->tlink
)
1262 if (p
->tlink
== sym
)
1264 p
->tlink
= sym
->tlink
;
1268 switch_types (sym
->ns
->sym_root
, sym
, s
);
1270 /* TODO: Also have to replace sym -> s in other lists like
1271 namelists, common lists and interface lists. */
1272 gfc_free_symbol (sym
);
1277 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1283 /* Given a derived type node and a component name, try to locate the
1284 component structure. Returns the NULL pointer if the component is
1285 not found or the components are private. */
1288 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1295 sym
= gfc_use_derived (sym
);
1300 for (p
= sym
->components
; p
; p
= p
->next
)
1301 if (strcmp (p
->name
, name
) == 0)
1305 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1309 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1311 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1321 /* Given a symbol, free all of the component structures and everything
1325 free_components (gfc_component
* p
)
1333 gfc_free_array_spec (p
->as
);
1334 gfc_free_expr (p
->initializer
);
1341 /* Set component attributes from a standard symbol attribute
1345 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1348 c
->dimension
= attr
->dimension
;
1349 c
->pointer
= attr
->pointer
;
1353 /* Get a standard symbol attribute structure given the component
1357 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1360 gfc_clear_attr (attr
);
1361 attr
->dimension
= c
->dimension
;
1362 attr
->pointer
= c
->pointer
;
1366 /******************** Statement label management ********************/
1368 /* Free a single gfc_st_label structure, making sure the list is not
1369 messed up. This function is called only when some parse error
1373 gfc_free_st_label (gfc_st_label
* l
)
1380 (l
->prev
->next
= l
->next
);
1383 (l
->next
->prev
= l
->prev
);
1385 if (l
->format
!= NULL
)
1386 gfc_free_expr (l
->format
);
1390 /* Free a whole list of gfc_st_label structures. */
1393 free_st_labels (gfc_st_label
* l1
)
1400 if (l1
->format
!= NULL
)
1401 gfc_free_expr (l1
->format
);
1407 /* Given a label number, search for and return a pointer to the label
1408 structure, creating it if it does not exist. */
1411 gfc_get_st_label (int labelno
)
1415 /* First see if the label is already in this namespace. */
1416 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1417 if (lp
->value
== labelno
)
1422 lp
= gfc_getmem (sizeof (gfc_st_label
));
1424 lp
->value
= labelno
;
1425 lp
->defined
= ST_LABEL_UNKNOWN
;
1426 lp
->referenced
= ST_LABEL_UNKNOWN
;
1429 lp
->next
= gfc_current_ns
->st_labels
;
1430 if (gfc_current_ns
->st_labels
)
1431 gfc_current_ns
->st_labels
->prev
= lp
;
1432 gfc_current_ns
->st_labels
= lp
;
1438 /* Called when a statement with a statement label is about to be
1439 accepted. We add the label to the list of the current namespace,
1440 making sure it hasn't been defined previously and referenced
1444 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1448 labelno
= lp
->value
;
1450 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1451 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1452 &lp
->where
, label_locus
);
1455 lp
->where
= *label_locus
;
1459 case ST_LABEL_FORMAT
:
1460 if (lp
->referenced
== ST_LABEL_TARGET
)
1461 gfc_error ("Label %d at %C already referenced as branch target",
1464 lp
->defined
= ST_LABEL_FORMAT
;
1468 case ST_LABEL_TARGET
:
1469 if (lp
->referenced
== ST_LABEL_FORMAT
)
1470 gfc_error ("Label %d at %C already referenced as a format label",
1473 lp
->defined
= ST_LABEL_TARGET
;
1478 lp
->defined
= ST_LABEL_BAD_TARGET
;
1479 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1485 /* Reference a label. Given a label and its type, see if that
1486 reference is consistent with what is known about that label,
1487 updating the unknown state. Returns FAILURE if something goes
1491 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1493 gfc_sl_type label_type
;
1500 labelno
= lp
->value
;
1502 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1503 label_type
= lp
->defined
;
1506 label_type
= lp
->referenced
;
1507 lp
->where
= gfc_current_locus
;
1510 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1512 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1517 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1518 && type
== ST_LABEL_FORMAT
)
1520 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1525 lp
->referenced
= type
;
1533 /************** Symbol table management subroutines ****************/
1535 /* Basic details: Fortran 95 requires a potentially unlimited number
1536 of distinct namespaces when compiling a program unit. This case
1537 occurs during a compilation of internal subprograms because all of
1538 the internal subprograms must be read before we can start
1539 generating code for the host.
1541 Given the tricky nature of the Fortran grammar, we must be able to
1542 undo changes made to a symbol table if the current interpretation
1543 of a statement is found to be incorrect. Whenever a symbol is
1544 looked up, we make a copy of it and link to it. All of these
1545 symbols are kept in a singly linked list so that we can commit or
1546 undo the changes at a later time.
1548 A symtree may point to a symbol node outside of its namespace. In
1549 this case, that symbol has been used as a host associated variable
1550 at some previous time. */
1552 /* Allocate a new namespace structure. Copies the implicit types from
1553 PARENT if PARENT_TYPES is set. */
1556 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1560 gfc_intrinsic_op in
;
1563 ns
= gfc_getmem (sizeof (gfc_namespace
));
1564 ns
->sym_root
= NULL
;
1565 ns
->uop_root
= NULL
;
1566 ns
->default_access
= ACCESS_UNKNOWN
;
1567 ns
->parent
= parent
;
1569 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1570 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1572 /* Initialize default implicit types. */
1573 for (i
= 'a'; i
<= 'z'; i
++)
1575 ns
->set_flag
[i
- 'a'] = 0;
1576 ts
= &ns
->default_type
[i
- 'a'];
1578 if (parent_types
&& ns
->parent
!= NULL
)
1580 /* Copy parent settings */
1581 *ts
= ns
->parent
->default_type
[i
- 'a'];
1585 if (gfc_option
.flag_implicit_none
!= 0)
1591 if ('i' <= i
&& i
<= 'n')
1593 ts
->type
= BT_INTEGER
;
1594 ts
->kind
= gfc_default_integer_kind
;
1599 ts
->kind
= gfc_default_real_kind
;
1609 /* Comparison function for symtree nodes. */
1612 compare_symtree (void * _st1
, void * _st2
)
1614 gfc_symtree
*st1
, *st2
;
1616 st1
= (gfc_symtree
*) _st1
;
1617 st2
= (gfc_symtree
*) _st2
;
1619 return strcmp (st1
->name
, st2
->name
);
1623 /* Allocate a new symtree node and associate it with the new symbol. */
1626 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1630 st
= gfc_getmem (sizeof (gfc_symtree
));
1631 st
->name
= gfc_get_string (name
);
1633 gfc_insert_bbt (root
, st
, compare_symtree
);
1638 /* Delete a symbol from the tree. Does not free the symbol itself! */
1641 delete_symtree (gfc_symtree
** root
, const char *name
)
1643 gfc_symtree st
, *st0
;
1645 st0
= gfc_find_symtree (*root
, name
);
1647 st
.name
= gfc_get_string (name
);
1648 gfc_delete_bbt (root
, &st
, compare_symtree
);
1654 /* Given a root symtree node and a name, try to find the symbol within
1655 the namespace. Returns NULL if the symbol is not found. */
1658 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1664 c
= strcmp (name
, st
->name
);
1668 st
= (c
< 0) ? st
->left
: st
->right
;
1675 /* Given a name find a user operator node, creating it if it doesn't
1676 exist. These are much simpler than symbols because they can't be
1677 ambiguous with one another. */
1680 gfc_get_uop (const char *name
)
1685 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1689 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1691 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1692 uop
->name
= gfc_get_string (name
);
1693 uop
->access
= ACCESS_UNKNOWN
;
1694 uop
->ns
= gfc_current_ns
;
1700 /* Given a name find the user operator node. Returns NULL if it does
1704 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1709 ns
= gfc_current_ns
;
1711 st
= gfc_find_symtree (ns
->uop_root
, name
);
1712 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1716 /* Remove a gfc_symbol structure and everything it points to. */
1719 gfc_free_symbol (gfc_symbol
* sym
)
1725 gfc_free_array_spec (sym
->as
);
1727 free_components (sym
->components
);
1729 gfc_free_expr (sym
->value
);
1731 gfc_free_namelist (sym
->namelist
);
1733 gfc_free_namespace (sym
->formal_ns
);
1735 gfc_free_interface (sym
->generic
);
1737 gfc_free_formal_arglist (sym
->formal
);
1743 /* Allocate and initialize a new symbol node. */
1746 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1750 p
= gfc_getmem (sizeof (gfc_symbol
));
1752 gfc_clear_ts (&p
->ts
);
1753 gfc_clear_attr (&p
->attr
);
1756 p
->declared_at
= gfc_current_locus
;
1758 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1759 gfc_internal_error ("new_symbol(): Symbol name too long");
1761 p
->name
= gfc_get_string (name
);
1766 /* Generate an error if a symbol is ambiguous. */
1769 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1772 if (st
->n
.sym
->module
)
1773 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1774 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1776 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1777 "from current program unit", name
, st
->n
.sym
->name
);
1781 /* Search for a symtree starting in the current namespace, resorting to
1782 any parent namespaces if requested by a nonzero parent_flag.
1783 Returns nonzero if the name is ambiguous. */
1786 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1787 gfc_symtree
** result
)
1792 ns
= gfc_current_ns
;
1796 st
= gfc_find_symtree (ns
->sym_root
, name
);
1802 ambiguous_symbol (name
, st
);
1821 /* Same, but returns the symbol instead. */
1824 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1825 gfc_symbol
** result
)
1830 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1835 *result
= st
->n
.sym
;
1841 /* Save symbol with the information necessary to back it out. */
1844 save_symbol_data (gfc_symbol
* sym
)
1847 if (sym
->new || sym
->old_symbol
!= NULL
)
1850 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1851 *(sym
->old_symbol
) = *sym
;
1853 sym
->tlink
= changed_syms
;
1858 /* Given a name, find a symbol, or create it if it does not exist yet
1859 in the current namespace. If the symbol is found we make sure that
1862 The integer return code indicates
1864 1 The symbol name was ambiguous
1865 2 The name meant to be established was already host associated.
1867 So if the return value is nonzero, then an error was issued. */
1870 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1875 /* This doesn't usually happen during resolution. */
1877 ns
= gfc_current_ns
;
1879 /* Try to find the symbol in ns. */
1880 st
= gfc_find_symtree (ns
->sym_root
, name
);
1884 /* If not there, create a new symbol. */
1885 p
= gfc_new_symbol (name
, ns
);
1887 /* Add to the list of tentative symbols. */
1888 p
->old_symbol
= NULL
;
1889 p
->tlink
= changed_syms
;
1894 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1901 /* Make sure the existing symbol is OK. */
1904 ambiguous_symbol (name
, st
);
1910 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1912 /* Symbol is from another namespace. */
1913 gfc_error ("Symbol '%s' at %C has already been host associated",
1920 /* Copy in case this symbol is changed. */
1921 save_symbol_data (p
);
1930 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1936 i
= gfc_get_sym_tree (name
, ns
, &st
);
1941 *result
= st
->n
.sym
;
1948 /* Subroutine that searches for a symbol, creating it if it doesn't
1949 exist, but tries to host-associate the symbol if possible. */
1952 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
1957 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1960 save_symbol_data (st
->n
.sym
);
1966 if (gfc_current_ns
->parent
!= NULL
)
1968 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
1979 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
1984 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
1989 i
= gfc_get_ha_sym_tree (name
, &st
);
1992 *result
= st
->n
.sym
;
1999 /* Return true if both symbols could refer to the same data object. Does
2000 not take account of aliasing due to equivalence statements. */
2003 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2005 /* Aliasing isn't possible if the symbols have different base types. */
2006 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2009 /* Pointers can point to other pointers, target objects and allocatable
2010 objects. Two allocatable objects cannot share the same storage. */
2011 if (lsym
->attr
.pointer
2012 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2014 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2016 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2023 /* Undoes all the changes made to symbols in the current statement.
2024 This subroutine is made simpler due to the fact that attributes are
2025 never removed once added. */
2028 gfc_undo_symbols (void)
2030 gfc_symbol
*p
, *q
, *old
;
2032 for (p
= changed_syms
; p
; p
= q
)
2038 /* Symbol was new. */
2039 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2043 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2045 gfc_free_symbol (p
);
2049 /* Restore previous state of symbol. Just copy simple stuff. */
2051 old
= p
->old_symbol
;
2053 p
->ts
.type
= old
->ts
.type
;
2054 p
->ts
.kind
= old
->ts
.kind
;
2056 p
->attr
= old
->attr
;
2058 if (p
->value
!= old
->value
)
2060 gfc_free_expr (old
->value
);
2064 if (p
->as
!= old
->as
)
2067 gfc_free_array_spec (p
->as
);
2071 p
->generic
= old
->generic
;
2072 p
->component_access
= old
->component_access
;
2074 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2076 gfc_free_namelist (p
->namelist
);
2082 if (p
->namelist_tail
!= old
->namelist_tail
)
2084 gfc_free_namelist (old
->namelist_tail
);
2085 old
->namelist_tail
->next
= NULL
;
2089 p
->namelist_tail
= old
->namelist_tail
;
2091 if (p
->formal
!= old
->formal
)
2093 gfc_free_formal_arglist (p
->formal
);
2094 p
->formal
= old
->formal
;
2097 gfc_free (p
->old_symbol
);
2098 p
->old_symbol
= NULL
;
2102 changed_syms
= NULL
;
2106 /* Makes the changes made in the current statement permanent-- gets
2107 rid of undo information. */
2110 gfc_commit_symbols (void)
2114 for (p
= changed_syms
; p
; p
= q
)
2121 if (p
->old_symbol
!= NULL
)
2123 gfc_free (p
->old_symbol
);
2124 p
->old_symbol
= NULL
;
2128 changed_syms
= NULL
;
2132 /* Recursive function that deletes an entire tree and all the common
2133 head structures it points to. */
2136 free_common_tree (gfc_symtree
* common_tree
)
2138 if (common_tree
== NULL
)
2141 free_common_tree (common_tree
->left
);
2142 free_common_tree (common_tree
->right
);
2144 gfc_free (common_tree
);
2148 /* Recursive function that deletes an entire tree and all the user
2149 operator nodes that it contains. */
2152 free_uop_tree (gfc_symtree
* uop_tree
)
2155 if (uop_tree
== NULL
)
2158 free_uop_tree (uop_tree
->left
);
2159 free_uop_tree (uop_tree
->right
);
2161 gfc_free_interface (uop_tree
->n
.uop
->operator);
2163 gfc_free (uop_tree
->n
.uop
);
2164 gfc_free (uop_tree
);
2168 /* Recursive function that deletes an entire tree and all the symbols
2169 that it contains. */
2172 free_sym_tree (gfc_symtree
* sym_tree
)
2177 if (sym_tree
== NULL
)
2180 free_sym_tree (sym_tree
->left
);
2181 free_sym_tree (sym_tree
->right
);
2183 sym
= sym_tree
->n
.sym
;
2187 gfc_internal_error ("free_sym_tree(): Negative refs");
2189 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2191 /* As formal_ns contains a reference to sym, delete formal_ns just
2192 before the deletion of sym. */
2193 ns
= sym
->formal_ns
;
2194 sym
->formal_ns
= NULL
;
2195 gfc_free_namespace (ns
);
2197 else if (sym
->refs
== 0)
2199 /* Go ahead and delete the symbol. */
2200 gfc_free_symbol (sym
);
2203 gfc_free (sym_tree
);
2207 /* Free a namespace structure and everything below it. Interface
2208 lists associated with intrinsic operators are not freed. These are
2209 taken care of when a specific name is freed. */
2212 gfc_free_namespace (gfc_namespace
* ns
)
2214 gfc_charlen
*cl
, *cl2
;
2215 gfc_namespace
*p
, *q
;
2224 gcc_assert (ns
->refs
== 0);
2226 gfc_free_statements (ns
->code
);
2228 free_sym_tree (ns
->sym_root
);
2229 free_uop_tree (ns
->uop_root
);
2230 free_common_tree (ns
->common_root
);
2232 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2235 gfc_free_expr (cl
->length
);
2239 free_st_labels (ns
->st_labels
);
2241 gfc_free_equiv (ns
->equiv
);
2243 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2244 gfc_free_interface (ns
->operator[i
]);
2246 gfc_free_data (ns
->data
);
2250 /* Recursively free any contained namespaces. */
2256 gfc_free_namespace (q
);
2262 gfc_symbol_init_2 (void)
2265 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2270 gfc_symbol_done_2 (void)
2273 gfc_free_namespace (gfc_current_ns
);
2274 gfc_current_ns
= NULL
;
2278 /* Clear mark bits from symbol nodes associated with a symtree node. */
2281 clear_sym_mark (gfc_symtree
* st
)
2284 st
->n
.sym
->mark
= 0;
2288 /* Recursively traverse the symtree nodes. */
2291 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2297 gfc_traverse_symtree (st
->left
, func
);
2298 gfc_traverse_symtree (st
->right
, func
);
2303 /* Recursive namespace traversal function. */
2306 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2312 if (st
->n
.sym
->mark
== 0)
2313 (*func
) (st
->n
.sym
);
2314 st
->n
.sym
->mark
= 1;
2316 traverse_ns (st
->left
, func
);
2317 traverse_ns (st
->right
, func
);
2321 /* Call a given function for all symbols in the namespace. We take
2322 care that each gfc_symbol node is called exactly once. */
2325 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2328 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2330 traverse_ns (ns
->sym_root
, func
);
2334 /* Return TRUE if the symbol is an automatic variable. */
2336 gfc_is_var_automatic (gfc_symbol
* sym
)
2338 /* Pointer and allocatable variables are never automatic. */
2339 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2341 /* Check for arrays with non-constant size. */
2342 if (sym
->attr
.dimension
&& sym
->as
2343 && !gfc_is_compile_time_shape (sym
->as
))
2345 /* Check for non-constant length character vairables. */
2346 if (sym
->ts
.type
== BT_CHARACTER
2348 && gfc_is_constant_expr (sym
->ts
.cl
->length
))
2353 /* Given a symbol, mark it as SAVEd if it is allowed. */
2356 save_symbol (gfc_symbol
* sym
)
2359 if (sym
->attr
.use_assoc
)
2362 if (sym
->attr
.in_common
2364 || sym
->attr
.flavor
!= FL_VARIABLE
)
2366 /* Automatic objects are not saved. */
2367 if (gfc_is_var_automatic (sym
))
2369 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2373 /* Mark those symbols which can be SAVEd as such. */
2376 gfc_save_all (gfc_namespace
* ns
)
2379 gfc_traverse_ns (ns
, save_symbol
);
2384 /* Make sure that no changes to symbols are pending. */
2387 gfc_symbol_state(void) {
2389 if (changed_syms
!= NULL
)
2390 gfc_internal_error("Symbol changes still pending!");
2395 /************** Global symbol handling ************/
2398 /* Search a tree for the global symbol. */
2401 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2407 if (strcmp (symbol
->name
, name
) == 0)
2410 s
= gfc_find_gsymbol (symbol
->left
, name
);
2414 s
= gfc_find_gsymbol (symbol
->right
, name
);
2422 /* Compare two global symbols. Used for managing the BB tree. */
2425 gsym_compare (void * _s1
, void * _s2
)
2427 gfc_gsymbol
*s1
, *s2
;
2429 s1
= (gfc_gsymbol
*)_s1
;
2430 s2
= (gfc_gsymbol
*)_s2
;
2431 return strcmp(s1
->name
, s2
->name
);
2435 /* Get a global symbol, creating it if it doesn't exist. */
2438 gfc_get_gsymbol (const char *name
)
2442 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2446 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2447 s
->type
= GSYM_UNKNOWN
;
2448 s
->name
= gfc_get_string (name
);
2450 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);