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, 59 Temple Place - Suite 330, 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 for (i
= 0; i
< GFC_LETTERS
; i
++)
111 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
112 gfc_current_ns
->set_flag
[i
] = 1;
117 /* Reset the implicit range flags. */
120 gfc_clear_new_implicit (void)
124 for (i
= 0; i
< GFC_LETTERS
; i
++)
129 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
132 gfc_add_new_implicit_range (int c1
, int c2
)
139 for (i
= c1
; i
<= c2
; i
++)
143 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
155 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
156 the new implicit types back into the existing types will work. */
159 gfc_merge_new_implicit (gfc_typespec
* ts
)
163 for (i
= 0; i
< GFC_LETTERS
; i
++)
168 if (gfc_current_ns
->set_flag
[i
])
170 gfc_error ("Letter %c already has an IMPLICIT type at %C",
174 gfc_current_ns
->default_type
[i
] = *ts
;
175 gfc_current_ns
->set_flag
[i
] = 1;
182 /* Given a symbol, return a pointer to the typespec for it's default
186 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
190 letter
= sym
->name
[0];
191 if (letter
< 'a' || letter
> 'z')
192 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
197 return &ns
->default_type
[letter
- 'a'];
201 /* Given a pointer to a symbol, set its type according to the first
202 letter of its name. Fails if the letter in question has no default
206 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
210 if (sym
->ts
.type
!= BT_UNKNOWN
)
211 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
213 ts
= gfc_get_default_type (sym
, ns
);
215 if (ts
->type
== BT_UNKNOWN
)
218 gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym
->name
,
225 sym
->attr
.implicit_type
= 1;
231 /******************** Symbol attribute stuff *********************/
233 /* This is a generic conflict-checker. We do this to avoid having a
234 single conflict in two places. */
236 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
237 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
240 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
242 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
243 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
244 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
245 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
246 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
247 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
248 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
249 *dimension
= "DIMENSION";
254 where
= &gfc_current_locus
;
256 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
263 /* Check for attributes not allowed in a BLOCK DATA. */
264 if (gfc_current_state () == COMP_BLOCK_DATA
)
268 if (attr
->allocatable
)
274 if (attr
->access
== ACCESS_PRIVATE
)
276 if (attr
->access
== ACCESS_PUBLIC
)
278 if (attr
->intent
!= INTENT_UNKNOWN
)
284 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
291 conf (pointer
, target
);
292 conf (pointer
, external
);
293 conf (pointer
, intrinsic
);
294 conf (target
, external
);
295 conf (target
, intrinsic
);
296 conf (external
, dimension
); /* See Fortran 95's R504. */
298 conf (external
, intrinsic
);
299 conf (allocatable
, pointer
);
300 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
301 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
302 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
303 conf (elemental
, recursive
);
305 conf (in_common
, dummy
);
306 conf (in_common
, allocatable
);
307 conf (in_common
, result
);
308 conf (dummy
, result
);
310 conf (in_namelist
, pointer
);
311 conf (in_namelist
, allocatable
);
313 conf (entry
, result
);
315 conf (function
, subroutine
);
317 a1
= gfc_code2string (flavors
, attr
->flavor
);
319 if (attr
->in_namelist
320 && attr
->flavor
!= FL_VARIABLE
321 && attr
->flavor
!= FL_UNKNOWN
)
328 switch (attr
->flavor
)
355 if (attr
->subroutine
)
368 case PROC_ST_FUNCTION
:
401 if (attr
->intent
!= INTENT_UNKNOWN
)
430 gfc_error ("%s attribute conflicts with %s attribute at %L",
433 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
434 a1
, a2
, name
, where
);
443 /* Mark a symbol as referenced. */
446 gfc_set_sym_referenced (gfc_symbol
* sym
)
448 if (sym
->attr
.referenced
)
451 sym
->attr
.referenced
= 1;
453 /* Remember which order dummy variables are accessed in. */
455 sym
->dummy_order
= next_dummy_order
++;
459 /* Common subroutine called by attribute changing subroutines in order
460 to prevent them from changing a symbol that has been
461 use-associated. Returns zero if it is OK to change the symbol,
465 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
468 if (attr
->use_assoc
== 0)
472 where
= &gfc_current_locus
;
475 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
478 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
485 /* Used to prevent changing the attributes of a symbol after it has been
486 used. This check is only done from dummy variable as only these can be
487 used in specification expressions. Applying this to all symbols causes
488 error when we reach the body of a contained function. */
491 check_done (symbol_attribute
* attr
, locus
* where
)
494 if (!(attr
->dummy
&& attr
->referenced
))
498 where
= &gfc_current_locus
;
500 gfc_error ("Cannot change attributes of symbol at %L"
501 " after it has been used", where
);
507 /* Generate an error because of a duplicate attribute. */
510 duplicate_attr (const char *attr
, locus
* where
)
514 where
= &gfc_current_locus
;
516 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
521 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
524 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
527 if (attr
->allocatable
)
529 duplicate_attr ("ALLOCATABLE", where
);
533 attr
->allocatable
= 1;
534 return check_conflict (attr
, NULL
, where
);
539 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
542 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
547 duplicate_attr ("DIMENSION", where
);
552 return check_conflict (attr
, name
, where
);
557 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
560 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
565 duplicate_attr ("EXTERNAL", where
);
571 return check_conflict (attr
, NULL
, where
);
576 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
579 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
584 duplicate_attr ("INTRINSIC", where
);
590 return check_conflict (attr
, NULL
, where
);
595 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
598 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
603 duplicate_attr ("OPTIONAL", where
);
608 return check_conflict (attr
, NULL
, where
);
613 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
616 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
620 return check_conflict (attr
, NULL
, where
);
625 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
628 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
632 return check_conflict (attr
, name
, where
);
637 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
640 if (check_used (attr
, name
, where
))
646 ("SAVE attribute at %L cannot be specified in a PURE procedure",
653 duplicate_attr ("SAVE", where
);
658 return check_conflict (attr
, name
, where
);
663 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
666 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
671 duplicate_attr ("TARGET", where
);
676 return check_conflict (attr
, NULL
, where
);
681 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
684 if (check_used (attr
, name
, where
))
687 /* Duplicate dummy arguments are allow due to ENTRY statements. */
689 return check_conflict (attr
, name
, where
);
694 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
697 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
700 /* Duplicate attribute already checked for. */
702 if (check_conflict (attr
, name
, where
) == FAILURE
)
705 if (attr
->flavor
== FL_VARIABLE
)
708 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
713 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
716 if (check_used (attr
, name
, where
))
720 return check_conflict (attr
, name
, where
);
725 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
729 attr
->in_namelist
= 1;
730 return check_conflict (attr
, name
, where
);
735 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
738 if (check_used (attr
, name
, where
))
742 return check_conflict (attr
, name
, where
);
747 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
750 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
754 return check_conflict (attr
, NULL
, where
);
759 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
762 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
766 return check_conflict (attr
, NULL
, where
);
771 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
774 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
778 return check_conflict (attr
, NULL
, where
);
783 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
786 if (check_used (attr
, name
, where
))
791 duplicate_attr ("ENTRY", where
);
796 return check_conflict (attr
, name
, where
);
801 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
804 if (attr
->flavor
!= FL_PROCEDURE
805 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
809 return check_conflict (attr
, name
, where
);
814 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
817 if (attr
->flavor
!= FL_PROCEDURE
818 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
821 attr
->subroutine
= 1;
822 return check_conflict (attr
, name
, where
);
827 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
830 if (attr
->flavor
!= FL_PROCEDURE
831 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
835 return check_conflict (attr
, name
, where
);
839 /* Flavors are special because some flavors are not what fortran
840 considers attributes and can be reaffirmed multiple times. */
843 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
847 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
848 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
849 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
852 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
855 if (attr
->flavor
!= FL_UNKNOWN
)
858 where
= &gfc_current_locus
;
860 gfc_error ("%s attribute conflicts with %s attribute at %L",
861 gfc_code2string (flavors
, attr
->flavor
),
862 gfc_code2string (flavors
, f
), where
);
869 return check_conflict (attr
, name
, where
);
874 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
875 const char *name
, locus
* where
)
878 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
881 if (attr
->flavor
!= FL_PROCEDURE
882 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
886 where
= &gfc_current_locus
;
888 if (attr
->proc
!= PROC_UNKNOWN
)
890 gfc_error ("%s procedure at %L is already %s %s procedure",
891 gfc_code2string (procedures
, t
), where
,
892 gfc_article (gfc_code2string (procedures
, attr
->proc
)),
893 gfc_code2string (procedures
, attr
->proc
));
900 /* Statement functions are always scalar and functions. */
901 if (t
== PROC_ST_FUNCTION
902 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
906 return check_conflict (attr
, name
, where
);
911 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
914 if (check_used (attr
, NULL
, where
))
917 if (attr
->intent
== INTENT_UNKNOWN
)
919 attr
->intent
= intent
;
920 return check_conflict (attr
, NULL
, where
);
924 where
= &gfc_current_locus
;
926 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
927 gfc_intent_string (attr
->intent
),
928 gfc_intent_string (intent
), where
);
934 /* No checks for use-association in public and private statements. */
937 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
938 const char *name
, locus
* where
)
941 if (attr
->access
== ACCESS_UNKNOWN
)
943 attr
->access
= access
;
944 return check_conflict (attr
, name
, where
);
948 where
= &gfc_current_locus
;
949 gfc_error ("ACCESS specification at %L was already specified", where
);
956 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
957 gfc_formal_arglist
* formal
, locus
* where
)
960 if (check_used (&sym
->attr
, sym
->name
, where
))
964 where
= &gfc_current_locus
;
966 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
967 && sym
->attr
.if_source
!= IFSRC_DECL
)
969 gfc_error ("Symbol '%s' at %L already has an explicit interface",
974 sym
->formal
= formal
;
975 sym
->attr
.if_source
= source
;
981 /* Add a type to a symbol. */
984 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
988 /* TODO: This is legal if it is reaffirming an implicit type.
989 if (check_done (&sym->attr, where))
993 where
= &gfc_current_locus
;
995 if (sym
->ts
.type
!= BT_UNKNOWN
)
997 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
998 where
, gfc_basic_typename (sym
->ts
.type
));
1002 flavor
= sym
->attr
.flavor
;
1004 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1005 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1006 && sym
->attr
.subroutine
)
1007 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1009 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1018 /* Clears all attributes. */
1021 gfc_clear_attr (symbol_attribute
* attr
)
1023 memset (attr
, 0, sizeof(symbol_attribute
));
1027 /* Check for missing attributes in the new symbol. Currently does
1028 nothing, but it's not clear that it is unnecessary yet. */
1031 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1032 locus
* where ATTRIBUTE_UNUSED
)
1039 /* Copy an attribute to a symbol attribute, bit by bit. Some
1040 attributes have a lot of side-effects but cannot be present given
1041 where we are called from, so we ignore some bits. */
1044 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1047 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1050 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1052 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1054 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1056 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1058 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1060 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1062 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1067 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1070 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1073 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1075 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1077 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1080 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1082 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1084 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1086 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1089 if (src
->flavor
!= FL_UNKNOWN
1090 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1093 if (src
->intent
!= INTENT_UNKNOWN
1094 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1097 if (src
->access
!= ACCESS_UNKNOWN
1098 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1101 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1104 /* The subroutines that set these bits also cause flavors to be set,
1105 and that has already happened in the original, so don't let to
1110 dest
->intrinsic
= 1;
1119 /************** Component name management ************/
1121 /* Component names of a derived type form their own little namespaces
1122 that are separate from all other spaces. The space is composed of
1123 a singly linked list of gfc_component structures whose head is
1124 located in the parent symbol. */
1127 /* Add a component name to a symbol. The call fails if the name is
1128 already present. On success, the component pointer is modified to
1129 point to the additional component structure. */
1132 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1134 gfc_component
*p
, *tail
;
1138 for (p
= sym
->components
; p
; p
= p
->next
)
1140 if (strcmp (p
->name
, name
) == 0)
1142 gfc_error ("Component '%s' at %C already declared at %L",
1150 /* Allocate new component */
1151 p
= gfc_get_component ();
1154 sym
->components
= p
;
1158 strcpy (p
->name
, name
);
1159 p
->loc
= gfc_current_locus
;
1166 /* Recursive function to switch derived types of all symbol in a
1170 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1178 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1179 sym
->ts
.derived
= to
;
1181 switch_types (st
->left
, from
, to
);
1182 switch_types (st
->right
, from
, to
);
1186 /* This subroutine is called when a derived type is used in order to
1187 make the final determination about which version to use. The
1188 standard requires that a type be defined before it is 'used', but
1189 such types can appear in IMPLICIT statements before the actual
1190 definition. 'Using' in this context means declaring a variable to
1191 be that type or using the type constructor.
1193 If a type is used and the components haven't been defined, then we
1194 have to have a derived type in a parent unit. We find the node in
1195 the other namespace and point the symtree node in this namespace to
1196 that node. Further reference to this name point to the correct
1197 node. If we can't find the node in a parent namespace, then have
1200 This subroutine takes a pointer to a symbol node and returns a
1201 pointer to the translated node or NULL for an error. Usually there
1202 is no translation and we return the node we were passed. */
1204 static gfc_symtree
*
1205 gfc_use_ha_derived (gfc_symbol
* sym
)
1212 if (sym
->ns
->parent
== NULL
)
1215 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1217 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1221 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1224 /* Get rid of symbol sym, translating all references to s. */
1225 for (i
= 0; i
< GFC_LETTERS
; i
++)
1227 t
= &sym
->ns
->default_type
[i
];
1228 if (t
->derived
== sym
)
1232 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1237 /* Unlink from list of modified symbols. */
1238 if (changed_syms
== sym
)
1239 changed_syms
= sym
->tlink
;
1241 for (p
= changed_syms
; p
; p
= p
->tlink
)
1242 if (p
->tlink
== sym
)
1244 p
->tlink
= sym
->tlink
;
1248 switch_types (sym
->ns
->sym_root
, sym
, s
);
1250 /* TODO: Also have to replace sym -> s in other lists like
1251 namelists, common lists and interface lists. */
1252 gfc_free_symbol (sym
);
1257 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1264 gfc_use_derived (gfc_symbol
* sym
)
1268 if (sym
->components
!= NULL
)
1269 return sym
; /* Already defined */
1271 st
= gfc_use_ha_derived (sym
);
1279 /* Given a derived type node and a component name, try to locate the
1280 component structure. Returns the NULL pointer if the component is
1281 not found or the components are private. */
1284 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1291 sym
= gfc_use_derived (sym
);
1296 for (p
= sym
->components
; p
; p
= p
->next
)
1297 if (strcmp (p
->name
, name
) == 0)
1301 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1305 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1307 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1317 /* Given a symbol, free all of the component structures and everything
1321 free_components (gfc_component
* p
)
1329 gfc_free_array_spec (p
->as
);
1330 gfc_free_expr (p
->initializer
);
1337 /* Set component attributes from a standard symbol attribute
1341 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1344 c
->dimension
= attr
->dimension
;
1345 c
->pointer
= attr
->pointer
;
1349 /* Get a standard symbol attribute structure given the component
1353 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1356 gfc_clear_attr (attr
);
1357 attr
->dimension
= c
->dimension
;
1358 attr
->pointer
= c
->pointer
;
1362 /******************** Statement label management ********************/
1364 /* Free a single gfc_st_label structure, making sure the list is not
1365 messed up. This function is called only when some parse error
1369 gfc_free_st_label (gfc_st_label
* l
)
1376 (l
->prev
->next
= l
->next
);
1379 (l
->next
->prev
= l
->prev
);
1381 if (l
->format
!= NULL
)
1382 gfc_free_expr (l
->format
);
1386 /* Free a whole list of gfc_st_label structures. */
1389 free_st_labels (gfc_st_label
* l1
)
1396 if (l1
->format
!= NULL
)
1397 gfc_free_expr (l1
->format
);
1403 /* Given a label number, search for and return a pointer to the label
1404 structure, creating it if it does not exist. */
1407 gfc_get_st_label (int labelno
)
1411 /* First see if the label is already in this namespace. */
1412 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1413 if (lp
->value
== labelno
)
1418 lp
= gfc_getmem (sizeof (gfc_st_label
));
1420 lp
->value
= labelno
;
1421 lp
->defined
= ST_LABEL_UNKNOWN
;
1422 lp
->referenced
= ST_LABEL_UNKNOWN
;
1425 lp
->next
= gfc_current_ns
->st_labels
;
1426 if (gfc_current_ns
->st_labels
)
1427 gfc_current_ns
->st_labels
->prev
= lp
;
1428 gfc_current_ns
->st_labels
= lp
;
1434 /* Called when a statement with a statement label is about to be
1435 accepted. We add the label to the list of the current namespace,
1436 making sure it hasn't been defined previously and referenced
1440 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1444 labelno
= lp
->value
;
1446 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1447 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1448 &lp
->where
, label_locus
);
1451 lp
->where
= *label_locus
;
1455 case ST_LABEL_FORMAT
:
1456 if (lp
->referenced
== ST_LABEL_TARGET
)
1457 gfc_error ("Label %d at %C already referenced as branch target",
1460 lp
->defined
= ST_LABEL_FORMAT
;
1464 case ST_LABEL_TARGET
:
1465 if (lp
->referenced
== ST_LABEL_FORMAT
)
1466 gfc_error ("Label %d at %C already referenced as a format label",
1469 lp
->defined
= ST_LABEL_TARGET
;
1474 lp
->defined
= ST_LABEL_BAD_TARGET
;
1475 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1481 /* Reference a label. Given a label and its type, see if that
1482 reference is consistent with what is known about that label,
1483 updating the unknown state. Returns FAILURE if something goes
1487 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1489 gfc_sl_type label_type
;
1496 labelno
= lp
->value
;
1498 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1499 label_type
= lp
->defined
;
1502 label_type
= lp
->referenced
;
1503 lp
->where
= gfc_current_locus
;
1506 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1508 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1513 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1514 && type
== ST_LABEL_FORMAT
)
1516 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1521 lp
->referenced
= type
;
1529 /************** Symbol table management subroutines ****************/
1531 /* Basic details: Fortran 95 requires a potentially unlimited number
1532 of distinct namespaces when compiling a program unit. This case
1533 occurs during a compilation of internal subprograms because all of
1534 the internal subprograms must be read before we can start
1535 generating code for the host.
1537 Given the tricky nature of the fortran grammar, we must be able to
1538 undo changes made to a symbol table if the current interpretation
1539 of a statement is found to be incorrect. Whenever a symbol is
1540 looked up, we make a copy of it and link to it. All of these
1541 symbols are kept in a singly linked list so that we can commit or
1542 undo the changes at a later time.
1544 A symtree may point to a symbol node outside of its namespace. In
1545 this case, that symbol has been used as a host associated variable
1546 at some previous time. */
1548 /* Allocate a new namespace structure. */
1551 gfc_get_namespace (gfc_namespace
* parent
)
1555 gfc_intrinsic_op in
;
1558 ns
= gfc_getmem (sizeof (gfc_namespace
));
1559 ns
->sym_root
= NULL
;
1560 ns
->uop_root
= NULL
;
1561 ns
->default_access
= ACCESS_UNKNOWN
;
1562 ns
->parent
= parent
;
1564 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1565 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1567 /* Initialize default implicit types. */
1568 for (i
= 'a'; i
<= 'z'; i
++)
1570 ns
->set_flag
[i
- 'a'] = 0;
1571 ts
= &ns
->default_type
[i
- 'a'];
1573 if (ns
->parent
!= NULL
)
1575 /* Copy parent settings */
1576 *ts
= ns
->parent
->default_type
[i
- 'a'];
1580 if (gfc_option
.flag_implicit_none
!= 0)
1586 if ('i' <= i
&& i
<= 'n')
1588 ts
->type
= BT_INTEGER
;
1589 ts
->kind
= gfc_default_integer_kind
;
1594 ts
->kind
= gfc_default_real_kind
;
1604 /* Comparison function for symtree nodes. */
1607 compare_symtree (void * _st1
, void * _st2
)
1609 gfc_symtree
*st1
, *st2
;
1611 st1
= (gfc_symtree
*) _st1
;
1612 st2
= (gfc_symtree
*) _st2
;
1614 return strcmp (st1
->name
, st2
->name
);
1618 /* Allocate a new symtree node and associate it with the new symbol. */
1621 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1625 st
= gfc_getmem (sizeof (gfc_symtree
));
1626 strcpy (st
->name
, name
);
1628 gfc_insert_bbt (root
, st
, compare_symtree
);
1633 /* Delete a symbol from the tree. Does not free the symbol itself! */
1636 delete_symtree (gfc_symtree
** root
, const char *name
)
1638 gfc_symtree st
, *st0
;
1640 st0
= gfc_find_symtree (*root
, name
);
1642 strcpy (st
.name
, name
);
1643 gfc_delete_bbt (root
, &st
, compare_symtree
);
1649 /* Given a root symtree node and a name, try to find the symbol within
1650 the namespace. Returns NULL if the symbol is not found. */
1653 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1659 c
= strcmp (name
, st
->name
);
1663 st
= (c
< 0) ? st
->left
: st
->right
;
1670 /* Given a name find a user operator node, creating it if it doesn't
1671 exist. These are much simpler than symbols because they can't be
1672 ambiguous with one another. */
1675 gfc_get_uop (const char *name
)
1680 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1684 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1686 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1687 strcpy (uop
->name
, name
);
1688 uop
->access
= ACCESS_UNKNOWN
;
1689 uop
->ns
= gfc_current_ns
;
1695 /* Given a name find the user operator node. Returns NULL if it does
1699 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1704 ns
= gfc_current_ns
;
1706 st
= gfc_find_symtree (ns
->uop_root
, name
);
1707 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1711 /* Remove a gfc_symbol structure and everything it points to. */
1714 gfc_free_symbol (gfc_symbol
* sym
)
1720 gfc_free_array_spec (sym
->as
);
1722 free_components (sym
->components
);
1724 gfc_free_expr (sym
->value
);
1726 gfc_free_namelist (sym
->namelist
);
1728 gfc_free_namespace (sym
->formal_ns
);
1730 gfc_free_interface (sym
->generic
);
1732 gfc_free_formal_arglist (sym
->formal
);
1738 /* Allocate and initialize a new symbol node. */
1741 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1745 p
= gfc_getmem (sizeof (gfc_symbol
));
1747 gfc_clear_ts (&p
->ts
);
1748 gfc_clear_attr (&p
->attr
);
1751 p
->declared_at
= gfc_current_locus
;
1753 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1754 gfc_internal_error ("new_symbol(): Symbol name too long");
1756 strcpy (p
->name
, name
);
1761 /* Generate an error if a symbol is ambiguous. */
1764 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1767 if (st
->n
.sym
->module
[0])
1768 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1769 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1771 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1772 "from current program unit", name
, st
->n
.sym
->name
);
1776 /* Search for a symtree starting in the current namespace, resorting to
1777 any parent namespaces if requested by a nonzero parent_flag.
1778 Returns nonzero if the name is ambiguous. */
1781 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1782 gfc_symtree
** result
)
1787 ns
= gfc_current_ns
;
1791 st
= gfc_find_symtree (ns
->sym_root
, name
);
1797 ambiguous_symbol (name
, st
);
1816 /* Same, but returns the symbol instead. */
1819 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1820 gfc_symbol
** result
)
1825 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1830 *result
= st
->n
.sym
;
1836 /* Save symbol with the information necessary to back it out. */
1839 save_symbol_data (gfc_symbol
* sym
)
1842 if (sym
->new || sym
->old_symbol
!= NULL
)
1845 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1846 *(sym
->old_symbol
) = *sym
;
1848 sym
->tlink
= changed_syms
;
1853 /* Given a name, find a symbol, or create it if it does not exist yet
1854 in the current namespace. If the symbol is found we make sure that
1857 The integer return code indicates
1859 1 The symbol name was ambiguous
1860 2 The name meant to be established was already host associated.
1862 So if the return value is nonzero, then an error was issued. */
1865 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1870 /* This doesn't usually happen during resolution. */
1872 ns
= gfc_current_ns
;
1874 /* Try to find the symbol in ns. */
1875 st
= gfc_find_symtree (ns
->sym_root
, name
);
1879 /* If not there, create a new symbol. */
1880 p
= gfc_new_symbol (name
, ns
);
1882 /* Add to the list of tentative symbols. */
1883 p
->old_symbol
= NULL
;
1884 p
->tlink
= changed_syms
;
1889 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1896 /* Make sure the existing symbol is OK. */
1899 ambiguous_symbol (name
, st
);
1905 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1907 /* Symbol is from another namespace. */
1908 gfc_error ("Symbol '%s' at %C has already been host associated",
1915 /* Copy in case this symbol is changed. */
1916 save_symbol_data (p
);
1925 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1931 i
= gfc_get_sym_tree (name
, ns
, &st
);
1936 *result
= st
->n
.sym
;
1943 /* Subroutine that searches for a symbol, creating it if it doesn't
1944 exist, but tries to host-associate the symbol if possible. */
1947 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
1952 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1955 save_symbol_data (st
->n
.sym
);
1961 if (gfc_current_ns
->parent
!= NULL
)
1963 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
1974 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
1979 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
1984 i
= gfc_get_ha_sym_tree (name
, &st
);
1987 *result
= st
->n
.sym
;
1994 /* Return true if both symbols could refer to the same data object. Does
1995 not take account of aliasing due to equivalence statements. */
1998 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2000 /* Aliasing isn't possible if the symbols have different base types. */
2001 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2004 /* Pointers can point to other pointers, target objects and allocatable
2005 objects. Two allocatable objects cannot share the same storage. */
2006 if (lsym
->attr
.pointer
2007 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2009 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2011 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2018 /* Undoes all the changes made to symbols in the current statement.
2019 This subroutine is made simpler due to the fact that attributes are
2020 never removed once added. */
2023 gfc_undo_symbols (void)
2025 gfc_symbol
*p
, *q
, *old
;
2027 for (p
= changed_syms
; p
; p
= q
)
2033 /* Symbol was new. */
2034 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2038 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2040 gfc_free_symbol (p
);
2044 /* Restore previous state of symbol. Just copy simple stuff. */
2046 old
= p
->old_symbol
;
2048 p
->ts
.type
= old
->ts
.type
;
2049 p
->ts
.kind
= old
->ts
.kind
;
2051 p
->attr
= old
->attr
;
2053 if (p
->value
!= old
->value
)
2055 gfc_free_expr (old
->value
);
2059 if (p
->as
!= old
->as
)
2062 gfc_free_array_spec (p
->as
);
2066 p
->generic
= old
->generic
;
2067 p
->component_access
= old
->component_access
;
2069 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2071 gfc_free_namelist (p
->namelist
);
2077 if (p
->namelist_tail
!= old
->namelist_tail
)
2079 gfc_free_namelist (old
->namelist_tail
);
2080 old
->namelist_tail
->next
= NULL
;
2084 p
->namelist_tail
= old
->namelist_tail
;
2086 if (p
->formal
!= old
->formal
)
2088 gfc_free_formal_arglist (p
->formal
);
2089 p
->formal
= old
->formal
;
2092 gfc_free (p
->old_symbol
);
2093 p
->old_symbol
= NULL
;
2097 changed_syms
= NULL
;
2101 /* Makes the changes made in the current statement permanent-- gets
2102 rid of undo information. */
2105 gfc_commit_symbols (void)
2109 for (p
= changed_syms
; p
; p
= q
)
2116 if (p
->old_symbol
!= NULL
)
2118 gfc_free (p
->old_symbol
);
2119 p
->old_symbol
= NULL
;
2123 changed_syms
= NULL
;
2127 /* Recursive function that deletes an entire tree and all the common
2128 head structures it points to. */
2131 free_common_tree (gfc_symtree
* common_tree
)
2133 if (common_tree
== NULL
)
2136 free_common_tree (common_tree
->left
);
2137 free_common_tree (common_tree
->right
);
2139 gfc_free (common_tree
);
2143 /* Recursive function that deletes an entire tree and all the user
2144 operator nodes that it contains. */
2147 free_uop_tree (gfc_symtree
* uop_tree
)
2150 if (uop_tree
== NULL
)
2153 free_uop_tree (uop_tree
->left
);
2154 free_uop_tree (uop_tree
->right
);
2156 gfc_free_interface (uop_tree
->n
.uop
->operator);
2158 gfc_free (uop_tree
->n
.uop
);
2159 gfc_free (uop_tree
);
2163 /* Recursive function that deletes an entire tree and all the symbols
2164 that it contains. */
2167 free_sym_tree (gfc_symtree
* sym_tree
)
2172 if (sym_tree
== NULL
)
2175 free_sym_tree (sym_tree
->left
);
2176 free_sym_tree (sym_tree
->right
);
2178 sym
= sym_tree
->n
.sym
;
2182 gfc_internal_error ("free_sym_tree(): Negative refs");
2184 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2186 /* As formal_ns contains a reference to sym, delete formal_ns just
2187 before the deletion of sym. */
2188 ns
= sym
->formal_ns
;
2189 sym
->formal_ns
= NULL
;
2190 gfc_free_namespace (ns
);
2192 else if (sym
->refs
== 0)
2194 /* Go ahead and delete the symbol. */
2195 gfc_free_symbol (sym
);
2198 gfc_free (sym_tree
);
2202 /* Free a namespace structure and everything below it. Interface
2203 lists associated with intrinsic operators are not freed. These are
2204 taken care of when a specific name is freed. */
2207 gfc_free_namespace (gfc_namespace
* ns
)
2209 gfc_charlen
*cl
, *cl2
;
2210 gfc_namespace
*p
, *q
;
2219 gcc_assert (ns
->refs
== 0);
2221 gfc_free_statements (ns
->code
);
2223 free_sym_tree (ns
->sym_root
);
2224 free_uop_tree (ns
->uop_root
);
2225 free_common_tree (ns
->common_root
);
2227 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2230 gfc_free_expr (cl
->length
);
2234 free_st_labels (ns
->st_labels
);
2236 gfc_free_equiv (ns
->equiv
);
2238 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2239 gfc_free_interface (ns
->operator[i
]);
2241 gfc_free_data (ns
->data
);
2245 /* Recursively free any contained namespaces. */
2251 gfc_free_namespace (q
);
2257 gfc_symbol_init_2 (void)
2260 gfc_current_ns
= gfc_get_namespace (NULL
);
2265 gfc_symbol_done_2 (void)
2268 gfc_free_namespace (gfc_current_ns
);
2269 gfc_current_ns
= NULL
;
2273 /* Clear mark bits from symbol nodes associated with a symtree node. */
2276 clear_sym_mark (gfc_symtree
* st
)
2279 st
->n
.sym
->mark
= 0;
2283 /* Recursively traverse the symtree nodes. */
2286 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2292 gfc_traverse_symtree (st
->left
, func
);
2293 gfc_traverse_symtree (st
->right
, func
);
2298 /* Recursive namespace traversal function. */
2301 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2307 if (st
->n
.sym
->mark
== 0)
2308 (*func
) (st
->n
.sym
);
2309 st
->n
.sym
->mark
= 1;
2311 traverse_ns (st
->left
, func
);
2312 traverse_ns (st
->right
, func
);
2316 /* Call a given function for all symbols in the namespace. We take
2317 care that each gfc_symbol node is called exactly once. */
2320 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2323 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2325 traverse_ns (ns
->sym_root
, func
);
2329 /* Given a symbol, mark it as SAVEd if it is allowed. */
2332 save_symbol (gfc_symbol
* sym
)
2335 if (sym
->attr
.use_assoc
)
2338 if (sym
->attr
.in_common
2340 || sym
->attr
.flavor
!= FL_VARIABLE
)
2343 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2347 /* Mark those symbols which can be SAVEd as such. */
2350 gfc_save_all (gfc_namespace
* ns
)
2353 gfc_traverse_ns (ns
, save_symbol
);
2358 /* Make sure that no changes to symbols are pending. */
2361 gfc_symbol_state(void) {
2363 if (changed_syms
!= NULL
)
2364 gfc_internal_error("Symbol changes still pending!");
2369 /************** Global symbol handling ************/
2372 /* Search a tree for the global symbol. */
2375 gfc_find_gsymbol (gfc_gsymbol
*symbol
, char *name
)
2381 if (strcmp (symbol
->name
, name
) == 0)
2384 s
= gfc_find_gsymbol (symbol
->left
, name
);
2388 s
= gfc_find_gsymbol (symbol
->right
, name
);
2396 /* Compare two global symbols. Used for managing the BB tree. */
2399 gsym_compare (void * _s1
, void * _s2
)
2401 gfc_gsymbol
*s1
, *s2
;
2403 s1
= (gfc_gsymbol
*)_s1
;
2404 s2
= (gfc_gsymbol
*)_s2
;
2405 return strcmp(s1
->name
, s2
->name
);
2409 /* Get a global symbol, creating it if it doesn't exist. */
2412 gfc_get_gsymbol (char *name
)
2416 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2420 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2421 s
->type
= GSYM_UNKNOWN
;
2422 strcpy (s
->name
, name
);
2424 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);