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 its default type. */
185 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
189 letter
= sym
->name
[0];
190 if (letter
< 'a' || letter
> 'z')
191 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
196 return &ns
->default_type
[letter
- 'a'];
200 /* Given a pointer to a symbol, set its type according to the first
201 letter of its name. Fails if the letter in question has no default
205 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
209 if (sym
->ts
.type
!= BT_UNKNOWN
)
210 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
212 ts
= gfc_get_default_type (sym
, ns
);
214 if (ts
->type
== BT_UNKNOWN
)
216 if (error_flag
&& !sym
->attr
.untyped
)
218 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
219 sym
->name
, &sym
->declared_at
);
220 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
227 sym
->attr
.implicit_type
= 1;
233 /******************** Symbol attribute stuff *********************/
235 /* This is a generic conflict-checker. We do this to avoid having a
236 single conflict in two places. */
238 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
239 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
242 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
244 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
245 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
246 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
247 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
248 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
249 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
250 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
251 *dimension
= "DIMENSION";
256 where
= &gfc_current_locus
;
258 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
265 /* Check for attributes not allowed in a BLOCK DATA. */
266 if (gfc_current_state () == COMP_BLOCK_DATA
)
270 if (attr
->allocatable
)
276 if (attr
->access
== ACCESS_PRIVATE
)
278 if (attr
->access
== ACCESS_PUBLIC
)
280 if (attr
->intent
!= INTENT_UNKNOWN
)
286 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
293 conf (pointer
, target
);
294 conf (pointer
, external
);
295 conf (pointer
, intrinsic
);
296 conf (target
, external
);
297 conf (target
, intrinsic
);
298 conf (external
, dimension
); /* See Fortran 95's R504. */
300 conf (external
, intrinsic
);
301 conf (allocatable
, pointer
);
302 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
303 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
304 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
305 conf (elemental
, recursive
);
307 conf (in_common
, dummy
);
308 conf (in_common
, allocatable
);
309 conf (in_common
, result
);
310 conf (dummy
, result
);
312 conf (in_namelist
, pointer
);
313 conf (in_namelist
, allocatable
);
315 conf (entry
, result
);
317 conf (function
, subroutine
);
319 a1
= gfc_code2string (flavors
, attr
->flavor
);
321 if (attr
->in_namelist
322 && attr
->flavor
!= FL_VARIABLE
323 && attr
->flavor
!= FL_UNKNOWN
)
330 switch (attr
->flavor
)
357 if (attr
->subroutine
)
370 case PROC_ST_FUNCTION
:
404 if (attr
->intent
!= INTENT_UNKNOWN
)
433 gfc_error ("%s attribute conflicts with %s attribute at %L",
436 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
437 a1
, a2
, name
, where
);
446 /* Mark a symbol as referenced. */
449 gfc_set_sym_referenced (gfc_symbol
* sym
)
451 if (sym
->attr
.referenced
)
454 sym
->attr
.referenced
= 1;
456 /* Remember which order dummy variables are accessed in. */
458 sym
->dummy_order
= next_dummy_order
++;
462 /* Common subroutine called by attribute changing subroutines in order
463 to prevent them from changing a symbol that has been
464 use-associated. Returns zero if it is OK to change the symbol,
468 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
471 if (attr
->use_assoc
== 0)
475 where
= &gfc_current_locus
;
478 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
481 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
488 /* Used to prevent changing the attributes of a symbol after it has been
489 used. This check is only done for dummy variables as only these can be
490 used in specification expressions. Applying this to all symbols causes
491 an error when we reach the body of a contained function. */
494 check_done (symbol_attribute
* attr
, locus
* where
)
497 if (!(attr
->dummy
&& attr
->referenced
))
501 where
= &gfc_current_locus
;
503 gfc_error ("Cannot change attributes of symbol at %L"
504 " after it has been used", where
);
510 /* Generate an error because of a duplicate attribute. */
513 duplicate_attr (const char *attr
, locus
* where
)
517 where
= &gfc_current_locus
;
519 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
524 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
527 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
530 if (attr
->allocatable
)
532 duplicate_attr ("ALLOCATABLE", where
);
536 attr
->allocatable
= 1;
537 return check_conflict (attr
, NULL
, where
);
542 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
545 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
550 duplicate_attr ("DIMENSION", where
);
555 return check_conflict (attr
, name
, where
);
560 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
563 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
568 duplicate_attr ("EXTERNAL", where
);
574 return check_conflict (attr
, NULL
, where
);
579 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
582 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
587 duplicate_attr ("INTRINSIC", where
);
593 return check_conflict (attr
, NULL
, where
);
598 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
601 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
606 duplicate_attr ("OPTIONAL", where
);
611 return check_conflict (attr
, NULL
, where
);
616 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
619 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
623 return check_conflict (attr
, NULL
, where
);
628 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
631 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
635 return check_conflict (attr
, name
, where
);
640 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
643 if (check_used (attr
, name
, where
))
649 ("SAVE attribute at %L cannot be specified in a PURE procedure",
656 duplicate_attr ("SAVE", where
);
661 return check_conflict (attr
, name
, where
);
666 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
669 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
674 duplicate_attr ("TARGET", where
);
679 return check_conflict (attr
, NULL
, where
);
684 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
687 if (check_used (attr
, name
, where
))
690 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
692 return check_conflict (attr
, name
, where
);
697 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
700 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
703 /* Duplicate attribute already checked for. */
705 if (check_conflict (attr
, name
, where
) == FAILURE
)
708 if (attr
->flavor
== FL_VARIABLE
)
711 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
716 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
719 if (check_used (attr
, name
, where
))
723 return check_conflict (attr
, name
, where
);
728 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
732 attr
->in_namelist
= 1;
733 return check_conflict (attr
, name
, where
);
738 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
741 if (check_used (attr
, name
, where
))
745 return check_conflict (attr
, name
, where
);
750 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
753 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
757 return check_conflict (attr
, NULL
, where
);
762 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
765 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
769 return check_conflict (attr
, NULL
, where
);
774 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
777 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
781 return check_conflict (attr
, NULL
, where
);
786 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
789 if (check_used (attr
, name
, where
))
794 duplicate_attr ("ENTRY", where
);
799 return check_conflict (attr
, name
, where
);
804 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
807 if (attr
->flavor
!= FL_PROCEDURE
808 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
812 return check_conflict (attr
, name
, where
);
817 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
820 if (attr
->flavor
!= FL_PROCEDURE
821 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
824 attr
->subroutine
= 1;
825 return check_conflict (attr
, name
, where
);
830 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
833 if (attr
->flavor
!= FL_PROCEDURE
834 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
838 return check_conflict (attr
, name
, where
);
842 /* Flavors are special because some flavors are not what Fortran
843 considers attributes and can be reaffirmed multiple times. */
846 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
850 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
851 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
852 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
855 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
858 if (attr
->flavor
!= FL_UNKNOWN
)
861 where
= &gfc_current_locus
;
863 gfc_error ("%s attribute conflicts with %s attribute at %L",
864 gfc_code2string (flavors
, attr
->flavor
),
865 gfc_code2string (flavors
, f
), where
);
872 return check_conflict (attr
, name
, where
);
877 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
878 const char *name
, locus
* where
)
881 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
884 if (attr
->flavor
!= FL_PROCEDURE
885 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
889 where
= &gfc_current_locus
;
891 if (attr
->proc
!= PROC_UNKNOWN
)
893 gfc_error ("%s procedure at %L is already %s %s procedure",
894 gfc_code2string (procedures
, t
), where
,
895 gfc_article (gfc_code2string (procedures
, attr
->proc
)),
896 gfc_code2string (procedures
, attr
->proc
));
903 /* Statement functions are always scalar and functions. */
904 if (t
== PROC_ST_FUNCTION
905 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
909 return check_conflict (attr
, name
, where
);
914 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
917 if (check_used (attr
, NULL
, where
))
920 if (attr
->intent
== INTENT_UNKNOWN
)
922 attr
->intent
= intent
;
923 return check_conflict (attr
, NULL
, where
);
927 where
= &gfc_current_locus
;
929 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
930 gfc_intent_string (attr
->intent
),
931 gfc_intent_string (intent
), where
);
937 /* No checks for use-association in public and private statements. */
940 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
941 const char *name
, locus
* where
)
944 if (attr
->access
== ACCESS_UNKNOWN
)
946 attr
->access
= access
;
947 return check_conflict (attr
, name
, where
);
951 where
= &gfc_current_locus
;
952 gfc_error ("ACCESS specification at %L was already specified", where
);
959 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
960 gfc_formal_arglist
* formal
, locus
* where
)
963 if (check_used (&sym
->attr
, sym
->name
, where
))
967 where
= &gfc_current_locus
;
969 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
970 && sym
->attr
.if_source
!= IFSRC_DECL
)
972 gfc_error ("Symbol '%s' at %L already has an explicit interface",
977 sym
->formal
= formal
;
978 sym
->attr
.if_source
= source
;
984 /* Add a type to a symbol. */
987 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
991 /* TODO: This is legal if it is reaffirming an implicit type.
992 if (check_done (&sym->attr, where))
996 where
= &gfc_current_locus
;
998 if (sym
->ts
.type
!= BT_UNKNOWN
)
1000 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1001 where
, gfc_basic_typename (sym
->ts
.type
));
1005 flavor
= sym
->attr
.flavor
;
1007 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1008 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1009 && sym
->attr
.subroutine
)
1010 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1012 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1021 /* Clears all attributes. */
1024 gfc_clear_attr (symbol_attribute
* attr
)
1026 memset (attr
, 0, sizeof(symbol_attribute
));
1030 /* Check for missing attributes in the new symbol. Currently does
1031 nothing, but it's not clear that it is unnecessary yet. */
1034 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1035 locus
* where ATTRIBUTE_UNUSED
)
1042 /* Copy an attribute to a symbol attribute, bit by bit. Some
1043 attributes have a lot of side-effects but cannot be present given
1044 where we are called from, so we ignore some bits. */
1047 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1050 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1053 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1055 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1057 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1059 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1061 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1063 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1065 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1070 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1073 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1076 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1078 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1080 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1083 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1085 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1087 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1089 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1092 if (src
->flavor
!= FL_UNKNOWN
1093 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1096 if (src
->intent
!= INTENT_UNKNOWN
1097 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1100 if (src
->access
!= ACCESS_UNKNOWN
1101 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1104 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1107 /* The subroutines that set these bits also cause flavors to be set,
1108 and that has already happened in the original, so don't let it
1113 dest
->intrinsic
= 1;
1122 /************** Component name management ************/
1124 /* Component names of a derived type form their own little namespaces
1125 that are separate from all other spaces. The space is composed of
1126 a singly linked list of gfc_component structures whose head is
1127 located in the parent symbol. */
1130 /* Add a component name to a symbol. The call fails if the name is
1131 already present. On success, the component pointer is modified to
1132 point to the additional component structure. */
1135 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1137 gfc_component
*p
, *tail
;
1141 for (p
= sym
->components
; p
; p
= p
->next
)
1143 if (strcmp (p
->name
, name
) == 0)
1145 gfc_error ("Component '%s' at %C already declared at %L",
1153 /* Allocate a new component. */
1154 p
= gfc_get_component ();
1157 sym
->components
= p
;
1161 p
->name
= gfc_get_string (name
);
1162 p
->loc
= gfc_current_locus
;
1169 /* Recursive function to switch derived types of all symbol in a
1173 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1181 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1182 sym
->ts
.derived
= to
;
1184 switch_types (st
->left
, from
, to
);
1185 switch_types (st
->right
, from
, to
);
1189 /* This subroutine is called when a derived type is used in order to
1190 make the final determination about which version to use. The
1191 standard requires that a type be defined before it is 'used', but
1192 such types can appear in IMPLICIT statements before the actual
1193 definition. 'Using' in this context means declaring a variable to
1194 be that type or using the type constructor.
1196 If a type is used and the components haven't been defined, then we
1197 have to have a derived type in a parent unit. We find the node in
1198 the other namespace and point the symtree node in this namespace to
1199 that node. Further reference to this name point to the correct
1200 node. If we can't find the node in a parent namespace, then we have
1203 This subroutine takes a pointer to a symbol node and returns a
1204 pointer to the translated node or NULL for an error. Usually there
1205 is no translation and we return the node we were passed. */
1208 gfc_use_derived (gfc_symbol
* sym
)
1215 if (sym
->components
!= NULL
)
1216 return sym
; /* Already defined. */
1218 if (sym
->ns
->parent
== NULL
)
1221 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1223 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1227 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1230 /* Get rid of symbol sym, translating all references to s. */
1231 for (i
= 0; i
< GFC_LETTERS
; i
++)
1233 t
= &sym
->ns
->default_type
[i
];
1234 if (t
->derived
== sym
)
1238 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1243 /* Unlink from list of modified symbols. */
1244 if (changed_syms
== sym
)
1245 changed_syms
= sym
->tlink
;
1247 for (p
= changed_syms
; p
; p
= p
->tlink
)
1248 if (p
->tlink
== sym
)
1250 p
->tlink
= sym
->tlink
;
1254 switch_types (sym
->ns
->sym_root
, sym
, s
);
1256 /* TODO: Also have to replace sym -> s in other lists like
1257 namelists, common lists and interface lists. */
1258 gfc_free_symbol (sym
);
1263 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1269 /* Given a derived type node and a component name, try to locate the
1270 component structure. Returns the NULL pointer if the component is
1271 not found or the components are private. */
1274 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1281 sym
= gfc_use_derived (sym
);
1286 for (p
= sym
->components
; p
; p
= p
->next
)
1287 if (strcmp (p
->name
, name
) == 0)
1291 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1295 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1297 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1307 /* Given a symbol, free all of the component structures and everything
1311 free_components (gfc_component
* p
)
1319 gfc_free_array_spec (p
->as
);
1320 gfc_free_expr (p
->initializer
);
1327 /* Set component attributes from a standard symbol attribute
1331 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1334 c
->dimension
= attr
->dimension
;
1335 c
->pointer
= attr
->pointer
;
1339 /* Get a standard symbol attribute structure given the component
1343 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1346 gfc_clear_attr (attr
);
1347 attr
->dimension
= c
->dimension
;
1348 attr
->pointer
= c
->pointer
;
1352 /******************** Statement label management ********************/
1354 /* Free a single gfc_st_label structure, making sure the list is not
1355 messed up. This function is called only when some parse error
1359 gfc_free_st_label (gfc_st_label
* l
)
1366 (l
->prev
->next
= l
->next
);
1369 (l
->next
->prev
= l
->prev
);
1371 if (l
->format
!= NULL
)
1372 gfc_free_expr (l
->format
);
1376 /* Free a whole list of gfc_st_label structures. */
1379 free_st_labels (gfc_st_label
* l1
)
1386 if (l1
->format
!= NULL
)
1387 gfc_free_expr (l1
->format
);
1393 /* Given a label number, search for and return a pointer to the label
1394 structure, creating it if it does not exist. */
1397 gfc_get_st_label (int labelno
)
1401 /* First see if the label is already in this namespace. */
1402 for (lp
= gfc_current_ns
->st_labels
; lp
; lp
= lp
->next
)
1403 if (lp
->value
== labelno
)
1408 lp
= gfc_getmem (sizeof (gfc_st_label
));
1410 lp
->value
= labelno
;
1411 lp
->defined
= ST_LABEL_UNKNOWN
;
1412 lp
->referenced
= ST_LABEL_UNKNOWN
;
1415 lp
->next
= gfc_current_ns
->st_labels
;
1416 if (gfc_current_ns
->st_labels
)
1417 gfc_current_ns
->st_labels
->prev
= lp
;
1418 gfc_current_ns
->st_labels
= lp
;
1424 /* Called when a statement with a statement label is about to be
1425 accepted. We add the label to the list of the current namespace,
1426 making sure it hasn't been defined previously and referenced
1430 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1434 labelno
= lp
->value
;
1436 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1437 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1438 &lp
->where
, label_locus
);
1441 lp
->where
= *label_locus
;
1445 case ST_LABEL_FORMAT
:
1446 if (lp
->referenced
== ST_LABEL_TARGET
)
1447 gfc_error ("Label %d at %C already referenced as branch target",
1450 lp
->defined
= ST_LABEL_FORMAT
;
1454 case ST_LABEL_TARGET
:
1455 if (lp
->referenced
== ST_LABEL_FORMAT
)
1456 gfc_error ("Label %d at %C already referenced as a format label",
1459 lp
->defined
= ST_LABEL_TARGET
;
1464 lp
->defined
= ST_LABEL_BAD_TARGET
;
1465 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1471 /* Reference a label. Given a label and its type, see if that
1472 reference is consistent with what is known about that label,
1473 updating the unknown state. Returns FAILURE if something goes
1477 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1479 gfc_sl_type label_type
;
1486 labelno
= lp
->value
;
1488 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1489 label_type
= lp
->defined
;
1492 label_type
= lp
->referenced
;
1493 lp
->where
= gfc_current_locus
;
1496 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1498 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1503 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1504 && type
== ST_LABEL_FORMAT
)
1506 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1511 lp
->referenced
= type
;
1519 /************** Symbol table management subroutines ****************/
1521 /* Basic details: Fortran 95 requires a potentially unlimited number
1522 of distinct namespaces when compiling a program unit. This case
1523 occurs during a compilation of internal subprograms because all of
1524 the internal subprograms must be read before we can start
1525 generating code for the host.
1527 Given the tricky nature of the Fortran grammar, we must be able to
1528 undo changes made to a symbol table if the current interpretation
1529 of a statement is found to be incorrect. Whenever a symbol is
1530 looked up, we make a copy of it and link to it. All of these
1531 symbols are kept in a singly linked list so that we can commit or
1532 undo the changes at a later time.
1534 A symtree may point to a symbol node outside of its namespace. In
1535 this case, that symbol has been used as a host associated variable
1536 at some previous time. */
1538 /* Allocate a new namespace structure. Copies the implicit types from
1539 PARENT if PARENT_TYPES is set. */
1542 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1546 gfc_intrinsic_op in
;
1549 ns
= gfc_getmem (sizeof (gfc_namespace
));
1550 ns
->sym_root
= NULL
;
1551 ns
->uop_root
= NULL
;
1552 ns
->default_access
= ACCESS_UNKNOWN
;
1553 ns
->parent
= parent
;
1555 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1556 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1558 /* Initialize default implicit types. */
1559 for (i
= 'a'; i
<= 'z'; i
++)
1561 ns
->set_flag
[i
- 'a'] = 0;
1562 ts
= &ns
->default_type
[i
- 'a'];
1564 if (parent_types
&& ns
->parent
!= NULL
)
1566 /* Copy parent settings */
1567 *ts
= ns
->parent
->default_type
[i
- 'a'];
1571 if (gfc_option
.flag_implicit_none
!= 0)
1577 if ('i' <= i
&& i
<= 'n')
1579 ts
->type
= BT_INTEGER
;
1580 ts
->kind
= gfc_default_integer_kind
;
1585 ts
->kind
= gfc_default_real_kind
;
1595 /* Comparison function for symtree nodes. */
1598 compare_symtree (void * _st1
, void * _st2
)
1600 gfc_symtree
*st1
, *st2
;
1602 st1
= (gfc_symtree
*) _st1
;
1603 st2
= (gfc_symtree
*) _st2
;
1605 return strcmp (st1
->name
, st2
->name
);
1609 /* Allocate a new symtree node and associate it with the new symbol. */
1612 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1616 st
= gfc_getmem (sizeof (gfc_symtree
));
1617 st
->name
= gfc_get_string (name
);
1619 gfc_insert_bbt (root
, st
, compare_symtree
);
1624 /* Delete a symbol from the tree. Does not free the symbol itself! */
1627 delete_symtree (gfc_symtree
** root
, const char *name
)
1629 gfc_symtree st
, *st0
;
1631 st0
= gfc_find_symtree (*root
, name
);
1633 st
.name
= gfc_get_string (name
);
1634 gfc_delete_bbt (root
, &st
, compare_symtree
);
1640 /* Given a root symtree node and a name, try to find the symbol within
1641 the namespace. Returns NULL if the symbol is not found. */
1644 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1650 c
= strcmp (name
, st
->name
);
1654 st
= (c
< 0) ? st
->left
: st
->right
;
1661 /* Given a name find a user operator node, creating it if it doesn't
1662 exist. These are much simpler than symbols because they can't be
1663 ambiguous with one another. */
1666 gfc_get_uop (const char *name
)
1671 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1675 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1677 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1678 uop
->name
= gfc_get_string (name
);
1679 uop
->access
= ACCESS_UNKNOWN
;
1680 uop
->ns
= gfc_current_ns
;
1686 /* Given a name find the user operator node. Returns NULL if it does
1690 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1695 ns
= gfc_current_ns
;
1697 st
= gfc_find_symtree (ns
->uop_root
, name
);
1698 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1702 /* Remove a gfc_symbol structure and everything it points to. */
1705 gfc_free_symbol (gfc_symbol
* sym
)
1711 gfc_free_array_spec (sym
->as
);
1713 free_components (sym
->components
);
1715 gfc_free_expr (sym
->value
);
1717 gfc_free_namelist (sym
->namelist
);
1719 gfc_free_namespace (sym
->formal_ns
);
1721 gfc_free_interface (sym
->generic
);
1723 gfc_free_formal_arglist (sym
->formal
);
1729 /* Allocate and initialize a new symbol node. */
1732 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1736 p
= gfc_getmem (sizeof (gfc_symbol
));
1738 gfc_clear_ts (&p
->ts
);
1739 gfc_clear_attr (&p
->attr
);
1742 p
->declared_at
= gfc_current_locus
;
1744 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1745 gfc_internal_error ("new_symbol(): Symbol name too long");
1747 p
->name
= gfc_get_string (name
);
1752 /* Generate an error if a symbol is ambiguous. */
1755 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1758 if (st
->n
.sym
->module
)
1759 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1760 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1762 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1763 "from current program unit", name
, st
->n
.sym
->name
);
1767 /* Search for a symtree starting in the current namespace, resorting to
1768 any parent namespaces if requested by a nonzero parent_flag.
1769 Returns nonzero if the name is ambiguous. */
1772 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1773 gfc_symtree
** result
)
1778 ns
= gfc_current_ns
;
1782 st
= gfc_find_symtree (ns
->sym_root
, name
);
1788 ambiguous_symbol (name
, st
);
1807 /* Same, but returns the symbol instead. */
1810 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1811 gfc_symbol
** result
)
1816 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1821 *result
= st
->n
.sym
;
1827 /* Save symbol with the information necessary to back it out. */
1830 save_symbol_data (gfc_symbol
* sym
)
1833 if (sym
->new || sym
->old_symbol
!= NULL
)
1836 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1837 *(sym
->old_symbol
) = *sym
;
1839 sym
->tlink
= changed_syms
;
1844 /* Given a name, find a symbol, or create it if it does not exist yet
1845 in the current namespace. If the symbol is found we make sure that
1848 The integer return code indicates
1850 1 The symbol name was ambiguous
1851 2 The name meant to be established was already host associated.
1853 So if the return value is nonzero, then an error was issued. */
1856 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
1861 /* This doesn't usually happen during resolution. */
1863 ns
= gfc_current_ns
;
1865 /* Try to find the symbol in ns. */
1866 st
= gfc_find_symtree (ns
->sym_root
, name
);
1870 /* If not there, create a new symbol. */
1871 p
= gfc_new_symbol (name
, ns
);
1873 /* Add to the list of tentative symbols. */
1874 p
->old_symbol
= NULL
;
1875 p
->tlink
= changed_syms
;
1880 st
= gfc_new_symtree (&ns
->sym_root
, name
);
1887 /* Make sure the existing symbol is OK. */
1890 ambiguous_symbol (name
, st
);
1896 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
1898 /* Symbol is from another namespace. */
1899 gfc_error ("Symbol '%s' at %C has already been host associated",
1906 /* Copy in case this symbol is changed. */
1907 save_symbol_data (p
);
1916 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
1922 i
= gfc_get_sym_tree (name
, ns
, &st
);
1927 *result
= st
->n
.sym
;
1934 /* Subroutine that searches for a symbol, creating it if it doesn't
1935 exist, but tries to host-associate the symbol if possible. */
1938 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
1943 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1946 save_symbol_data (st
->n
.sym
);
1952 if (gfc_current_ns
->parent
!= NULL
)
1954 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
1965 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
1970 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
1975 i
= gfc_get_ha_sym_tree (name
, &st
);
1978 *result
= st
->n
.sym
;
1985 /* Return true if both symbols could refer to the same data object. Does
1986 not take account of aliasing due to equivalence statements. */
1989 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
1991 /* Aliasing isn't possible if the symbols have different base types. */
1992 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
1995 /* Pointers can point to other pointers, target objects and allocatable
1996 objects. Two allocatable objects cannot share the same storage. */
1997 if (lsym
->attr
.pointer
1998 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2000 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2002 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2009 /* Undoes all the changes made to symbols in the current statement.
2010 This subroutine is made simpler due to the fact that attributes are
2011 never removed once added. */
2014 gfc_undo_symbols (void)
2016 gfc_symbol
*p
, *q
, *old
;
2018 for (p
= changed_syms
; p
; p
= q
)
2024 /* Symbol was new. */
2025 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2029 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2031 gfc_free_symbol (p
);
2035 /* Restore previous state of symbol. Just copy simple stuff. */
2037 old
= p
->old_symbol
;
2039 p
->ts
.type
= old
->ts
.type
;
2040 p
->ts
.kind
= old
->ts
.kind
;
2042 p
->attr
= old
->attr
;
2044 if (p
->value
!= old
->value
)
2046 gfc_free_expr (old
->value
);
2050 if (p
->as
!= old
->as
)
2053 gfc_free_array_spec (p
->as
);
2057 p
->generic
= old
->generic
;
2058 p
->component_access
= old
->component_access
;
2060 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2062 gfc_free_namelist (p
->namelist
);
2068 if (p
->namelist_tail
!= old
->namelist_tail
)
2070 gfc_free_namelist (old
->namelist_tail
);
2071 old
->namelist_tail
->next
= NULL
;
2075 p
->namelist_tail
= old
->namelist_tail
;
2077 if (p
->formal
!= old
->formal
)
2079 gfc_free_formal_arglist (p
->formal
);
2080 p
->formal
= old
->formal
;
2083 gfc_free (p
->old_symbol
);
2084 p
->old_symbol
= NULL
;
2088 changed_syms
= NULL
;
2092 /* Makes the changes made in the current statement permanent-- gets
2093 rid of undo information. */
2096 gfc_commit_symbols (void)
2100 for (p
= changed_syms
; p
; p
= q
)
2107 if (p
->old_symbol
!= NULL
)
2109 gfc_free (p
->old_symbol
);
2110 p
->old_symbol
= NULL
;
2114 changed_syms
= NULL
;
2118 /* Recursive function that deletes an entire tree and all the common
2119 head structures it points to. */
2122 free_common_tree (gfc_symtree
* common_tree
)
2124 if (common_tree
== NULL
)
2127 free_common_tree (common_tree
->left
);
2128 free_common_tree (common_tree
->right
);
2130 gfc_free (common_tree
);
2134 /* Recursive function that deletes an entire tree and all the user
2135 operator nodes that it contains. */
2138 free_uop_tree (gfc_symtree
* uop_tree
)
2141 if (uop_tree
== NULL
)
2144 free_uop_tree (uop_tree
->left
);
2145 free_uop_tree (uop_tree
->right
);
2147 gfc_free_interface (uop_tree
->n
.uop
->operator);
2149 gfc_free (uop_tree
->n
.uop
);
2150 gfc_free (uop_tree
);
2154 /* Recursive function that deletes an entire tree and all the symbols
2155 that it contains. */
2158 free_sym_tree (gfc_symtree
* sym_tree
)
2163 if (sym_tree
== NULL
)
2166 free_sym_tree (sym_tree
->left
);
2167 free_sym_tree (sym_tree
->right
);
2169 sym
= sym_tree
->n
.sym
;
2173 gfc_internal_error ("free_sym_tree(): Negative refs");
2175 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2177 /* As formal_ns contains a reference to sym, delete formal_ns just
2178 before the deletion of sym. */
2179 ns
= sym
->formal_ns
;
2180 sym
->formal_ns
= NULL
;
2181 gfc_free_namespace (ns
);
2183 else if (sym
->refs
== 0)
2185 /* Go ahead and delete the symbol. */
2186 gfc_free_symbol (sym
);
2189 gfc_free (sym_tree
);
2193 /* Free a namespace structure and everything below it. Interface
2194 lists associated with intrinsic operators are not freed. These are
2195 taken care of when a specific name is freed. */
2198 gfc_free_namespace (gfc_namespace
* ns
)
2200 gfc_charlen
*cl
, *cl2
;
2201 gfc_namespace
*p
, *q
;
2210 gcc_assert (ns
->refs
== 0);
2212 gfc_free_statements (ns
->code
);
2214 free_sym_tree (ns
->sym_root
);
2215 free_uop_tree (ns
->uop_root
);
2216 free_common_tree (ns
->common_root
);
2218 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2221 gfc_free_expr (cl
->length
);
2225 free_st_labels (ns
->st_labels
);
2227 gfc_free_equiv (ns
->equiv
);
2229 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2230 gfc_free_interface (ns
->operator[i
]);
2232 gfc_free_data (ns
->data
);
2236 /* Recursively free any contained namespaces. */
2242 gfc_free_namespace (q
);
2248 gfc_symbol_init_2 (void)
2251 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2256 gfc_symbol_done_2 (void)
2259 gfc_free_namespace (gfc_current_ns
);
2260 gfc_current_ns
= NULL
;
2264 /* Clear mark bits from symbol nodes associated with a symtree node. */
2267 clear_sym_mark (gfc_symtree
* st
)
2270 st
->n
.sym
->mark
= 0;
2274 /* Recursively traverse the symtree nodes. */
2277 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2283 gfc_traverse_symtree (st
->left
, func
);
2284 gfc_traverse_symtree (st
->right
, func
);
2289 /* Recursive namespace traversal function. */
2292 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2298 if (st
->n
.sym
->mark
== 0)
2299 (*func
) (st
->n
.sym
);
2300 st
->n
.sym
->mark
= 1;
2302 traverse_ns (st
->left
, func
);
2303 traverse_ns (st
->right
, func
);
2307 /* Call a given function for all symbols in the namespace. We take
2308 care that each gfc_symbol node is called exactly once. */
2311 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2314 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2316 traverse_ns (ns
->sym_root
, func
);
2320 /* Given a symbol, mark it as SAVEd if it is allowed. */
2323 save_symbol (gfc_symbol
* sym
)
2326 if (sym
->attr
.use_assoc
)
2329 if (sym
->attr
.in_common
2331 || sym
->attr
.flavor
!= FL_VARIABLE
)
2334 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2338 /* Mark those symbols which can be SAVEd as such. */
2341 gfc_save_all (gfc_namespace
* ns
)
2344 gfc_traverse_ns (ns
, save_symbol
);
2349 /* Make sure that no changes to symbols are pending. */
2352 gfc_symbol_state(void) {
2354 if (changed_syms
!= NULL
)
2355 gfc_internal_error("Symbol changes still pending!");
2360 /************** Global symbol handling ************/
2363 /* Search a tree for the global symbol. */
2366 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2372 if (strcmp (symbol
->name
, name
) == 0)
2375 s
= gfc_find_gsymbol (symbol
->left
, name
);
2379 s
= gfc_find_gsymbol (symbol
->right
, name
);
2387 /* Compare two global symbols. Used for managing the BB tree. */
2390 gsym_compare (void * _s1
, void * _s2
)
2392 gfc_gsymbol
*s1
, *s2
;
2394 s1
= (gfc_gsymbol
*)_s1
;
2395 s2
= (gfc_gsymbol
*)_s2
;
2396 return strcmp(s1
->name
, s2
->name
);
2400 /* Get a global symbol, creating it if it doesn't exist. */
2403 gfc_get_gsymbol (const char *name
)
2407 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2411 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2412 s
->type
= GSYM_UNKNOWN
;
2413 s
->name
= gfc_get_string (name
);
2415 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);