1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Strings for all symbol attributes. We use these for dumping the
30 parse tree, in error messages, and also when reading and writing
33 const mstring flavors
[] =
35 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
36 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
37 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
38 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
39 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 const mstring procedures
[] =
45 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
46 minit ("MODULE-PROC", PROC_MODULE
),
47 minit ("INTERNAL-PROC", PROC_INTERNAL
),
48 minit ("DUMMY-PROC", PROC_DUMMY
),
49 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
50 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
51 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
55 const mstring intents
[] =
57 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
58 minit ("IN", INTENT_IN
),
59 minit ("OUT", INTENT_OUT
),
60 minit ("INOUT", INTENT_INOUT
),
64 const mstring access_types
[] =
66 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
67 minit ("PUBLIC", ACCESS_PUBLIC
),
68 minit ("PRIVATE", ACCESS_PRIVATE
),
72 const mstring ifsrc_types
[] =
74 minit ("UNKNOWN", IFSRC_UNKNOWN
),
75 minit ("DECL", IFSRC_DECL
),
76 minit ("BODY", IFSRC_IFBODY
),
77 minit ("USAGE", IFSRC_USAGE
)
81 /* This is to make sure the backend generates setup code in the correct
84 static int next_dummy_order
= 1;
87 gfc_namespace
*gfc_current_ns
;
89 gfc_gsymbol
*gfc_gsym_root
= NULL
;
91 static gfc_symbol
*changed_syms
= NULL
;
94 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
96 /* The following static variable indicates whether a particular element has
97 been explicitly set or not. */
99 static int new_flag
[GFC_LETTERS
];
102 /* Handle a correctly parsed IMPLICIT NONE. */
105 gfc_set_implicit_none (void)
109 if (gfc_current_ns
->seen_implicit_none
)
111 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
115 gfc_current_ns
->seen_implicit_none
= 1;
117 for (i
= 0; i
< GFC_LETTERS
; i
++)
119 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
120 gfc_current_ns
->set_flag
[i
] = 1;
125 /* Reset the implicit range flags. */
128 gfc_clear_new_implicit (void)
132 for (i
= 0; i
< GFC_LETTERS
; i
++)
137 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
140 gfc_add_new_implicit_range (int c1
, int c2
)
147 for (i
= c1
; i
<= c2
; i
++)
151 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
163 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
164 the new implicit types back into the existing types will work. */
167 gfc_merge_new_implicit (gfc_typespec
* ts
)
171 if (gfc_current_ns
->seen_implicit_none
)
173 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
177 for (i
= 0; i
< GFC_LETTERS
; i
++)
182 if (gfc_current_ns
->set_flag
[i
])
184 gfc_error ("Letter %c already has an IMPLICIT type at %C",
188 gfc_current_ns
->default_type
[i
] = *ts
;
189 gfc_current_ns
->set_flag
[i
] = 1;
196 /* Given a symbol, return a pointer to the typespec for its default type. */
199 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
203 letter
= sym
->name
[0];
204 if (letter
< 'a' || letter
> 'z')
205 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
210 return &ns
->default_type
[letter
- 'a'];
214 /* Given a pointer to a symbol, set its type according to the first
215 letter of its name. Fails if the letter in question has no default
219 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
223 if (sym
->ts
.type
!= BT_UNKNOWN
)
224 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
226 ts
= gfc_get_default_type (sym
, ns
);
228 if (ts
->type
== BT_UNKNOWN
)
230 if (error_flag
&& !sym
->attr
.untyped
)
232 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
233 sym
->name
, &sym
->declared_at
);
234 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
241 sym
->attr
.implicit_type
= 1;
247 /******************** Symbol attribute stuff *********************/
249 /* This is a generic conflict-checker. We do this to avoid having a
250 single conflict in two places. */
252 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
253 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
256 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
258 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
259 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
260 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
261 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
262 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
263 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
264 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
265 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
266 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
267 *cray_pointee
= "CRAY POINTEE", *data
= "DATA";
272 where
= &gfc_current_locus
;
274 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
281 /* Check for attributes not allowed in a BLOCK DATA. */
282 if (gfc_current_state () == COMP_BLOCK_DATA
)
286 if (attr
->in_namelist
)
288 if (attr
->allocatable
)
294 if (attr
->access
== ACCESS_PRIVATE
)
296 if (attr
->access
== ACCESS_PUBLIC
)
298 if (attr
->intent
!= INTENT_UNKNOWN
)
304 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
311 conf (pointer
, target
);
312 conf (pointer
, external
);
313 conf (pointer
, intrinsic
);
314 conf (pointer
, elemental
);
316 conf (target
, external
);
317 conf (target
, intrinsic
);
318 conf (external
, dimension
); /* See Fortran 95's R504. */
320 conf (external
, intrinsic
);
322 if (attr
->if_source
|| attr
->contained
)
324 conf (external
, subroutine
);
325 conf (external
, function
);
328 conf (allocatable
, pointer
);
329 conf (allocatable
, dummy
); /* TODO: Allowed in Fortran 200x. */
330 conf (allocatable
, function
); /* TODO: Allowed in Fortran 200x. */
331 conf (allocatable
, result
); /* TODO: Allowed in Fortran 200x. */
332 conf (elemental
, recursive
);
334 conf (in_common
, dummy
);
335 conf (in_common
, allocatable
);
336 conf (in_common
, result
);
337 conf (in_common
, save
);
340 conf (dummy
, result
);
342 conf (in_equivalence
, use_assoc
);
343 conf (in_equivalence
, dummy
);
344 conf (in_equivalence
, target
);
345 conf (in_equivalence
, pointer
);
346 conf (in_equivalence
, function
);
347 conf (in_equivalence
, result
);
348 conf (in_equivalence
, entry
);
349 conf (in_equivalence
, allocatable
);
351 conf (in_namelist
, pointer
);
352 conf (in_namelist
, allocatable
);
354 conf (entry
, result
);
356 conf (function
, subroutine
);
358 /* Cray pointer/pointee conflicts. */
359 conf (cray_pointer
, cray_pointee
);
360 conf (cray_pointer
, dimension
);
361 conf (cray_pointer
, pointer
);
362 conf (cray_pointer
, target
);
363 conf (cray_pointer
, allocatable
);
364 conf (cray_pointer
, external
);
365 conf (cray_pointer
, intrinsic
);
366 conf (cray_pointer
, in_namelist
);
367 conf (cray_pointer
, function
);
368 conf (cray_pointer
, subroutine
);
369 conf (cray_pointer
, entry
);
371 conf (cray_pointee
, allocatable
);
372 conf (cray_pointee
, intent
);
373 conf (cray_pointee
, optional
);
374 conf (cray_pointee
, dummy
);
375 conf (cray_pointee
, target
);
376 conf (cray_pointee
, external
);
377 conf (cray_pointee
, intrinsic
);
378 conf (cray_pointee
, pointer
);
379 conf (cray_pointee
, function
);
380 conf (cray_pointee
, subroutine
);
381 conf (cray_pointee
, entry
);
382 conf (cray_pointee
, in_common
);
383 conf (cray_pointee
, in_equivalence
);
386 conf (data
, function
);
388 conf (data
, allocatable
);
389 conf (data
, use_assoc
);
391 a1
= gfc_code2string (flavors
, attr
->flavor
);
393 if (attr
->in_namelist
394 && attr
->flavor
!= FL_VARIABLE
395 && attr
->flavor
!= FL_UNKNOWN
)
402 switch (attr
->flavor
)
429 if (attr
->subroutine
)
442 case PROC_ST_FUNCTION
:
476 if (attr
->intent
!= INTENT_UNKNOWN
)
506 gfc_error ("%s attribute conflicts with %s attribute at %L",
509 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
510 a1
, a2
, name
, where
);
519 /* Mark a symbol as referenced. */
522 gfc_set_sym_referenced (gfc_symbol
* sym
)
524 if (sym
->attr
.referenced
)
527 sym
->attr
.referenced
= 1;
529 /* Remember which order dummy variables are accessed in. */
531 sym
->dummy_order
= next_dummy_order
++;
535 /* Common subroutine called by attribute changing subroutines in order
536 to prevent them from changing a symbol that has been
537 use-associated. Returns zero if it is OK to change the symbol,
541 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
544 if (attr
->use_assoc
== 0)
548 where
= &gfc_current_locus
;
551 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
554 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
561 /* Used to prevent changing the attributes of a symbol after it has been
562 used. This check is only done for dummy variables as only these can be
563 used in specification expressions. Applying this to all symbols causes
564 an error when we reach the body of a contained function. */
567 check_done (symbol_attribute
* attr
, locus
* where
)
570 if (!(attr
->dummy
&& attr
->referenced
))
574 where
= &gfc_current_locus
;
576 gfc_error ("Cannot change attributes of symbol at %L"
577 " after it has been used", where
);
583 /* Generate an error because of a duplicate attribute. */
586 duplicate_attr (const char *attr
, locus
* where
)
590 where
= &gfc_current_locus
;
592 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
595 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
598 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
, uint attr_intent
)
601 if (check_used (attr
, NULL
, where
)
602 || (attr_intent
== 0 && check_done (attr
, where
)))
605 return check_conflict (attr
, NULL
, where
);
609 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
612 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
615 if (attr
->allocatable
)
617 duplicate_attr ("ALLOCATABLE", where
);
621 attr
->allocatable
= 1;
622 return check_conflict (attr
, NULL
, where
);
627 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
630 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
635 duplicate_attr ("DIMENSION", where
);
640 return check_conflict (attr
, name
, where
);
645 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
648 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
653 duplicate_attr ("EXTERNAL", where
);
659 return check_conflict (attr
, NULL
, where
);
664 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
667 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
672 duplicate_attr ("INTRINSIC", where
);
678 return check_conflict (attr
, NULL
, where
);
683 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
686 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
691 duplicate_attr ("OPTIONAL", where
);
696 return check_conflict (attr
, NULL
, where
);
701 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
704 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
708 return check_conflict (attr
, NULL
, where
);
713 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
716 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
719 attr
->cray_pointer
= 1;
720 return check_conflict (attr
, NULL
, where
);
725 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
728 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
731 if (attr
->cray_pointee
)
733 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
734 " statements.", where
);
738 attr
->cray_pointee
= 1;
739 return check_conflict (attr
, NULL
, where
);
744 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
747 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
751 return check_conflict (attr
, name
, where
);
756 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
759 if (check_used (attr
, name
, where
))
765 ("SAVE attribute at %L cannot be specified in a PURE procedure",
772 if (gfc_notify_std (GFC_STD_LEGACY
,
773 "Duplicate SAVE attribute specified at %L",
780 return check_conflict (attr
, name
, where
);
785 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
788 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
793 duplicate_attr ("TARGET", where
);
798 return check_conflict (attr
, NULL
, where
);
803 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
806 if (check_used (attr
, name
, where
))
809 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
811 return check_conflict (attr
, name
, where
);
816 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
819 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
822 /* Duplicate attribute already checked for. */
824 if (check_conflict (attr
, name
, where
) == FAILURE
)
827 if (attr
->flavor
== FL_VARIABLE
)
830 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
834 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
837 /* Duplicate attribute already checked for. */
838 attr
->in_equivalence
= 1;
839 if (check_conflict (attr
, name
, where
) == FAILURE
)
842 if (attr
->flavor
== FL_VARIABLE
)
845 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
850 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
853 if (check_used (attr
, name
, where
))
857 return check_conflict (attr
, name
, where
);
862 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
866 attr
->in_namelist
= 1;
867 return check_conflict (attr
, name
, where
);
872 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
875 if (check_used (attr
, name
, where
))
879 return check_conflict (attr
, name
, where
);
884 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
887 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
891 return check_conflict (attr
, NULL
, where
);
896 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
899 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
903 return check_conflict (attr
, NULL
, where
);
908 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
911 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
915 return check_conflict (attr
, NULL
, where
);
920 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
923 if (check_used (attr
, name
, where
))
928 duplicate_attr ("ENTRY", where
);
933 return check_conflict (attr
, name
, where
);
938 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
941 if (attr
->flavor
!= FL_PROCEDURE
942 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
946 return check_conflict (attr
, name
, where
);
951 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
954 if (attr
->flavor
!= FL_PROCEDURE
955 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
958 attr
->subroutine
= 1;
959 return check_conflict (attr
, name
, where
);
964 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
967 if (attr
->flavor
!= FL_PROCEDURE
968 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
972 return check_conflict (attr
, name
, where
);
976 /* Flavors are special because some flavors are not what Fortran
977 considers attributes and can be reaffirmed multiple times. */
980 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
984 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
985 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
986 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
989 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
992 if (attr
->flavor
!= FL_UNKNOWN
)
995 where
= &gfc_current_locus
;
997 gfc_error ("%s attribute conflicts with %s attribute at %L",
998 gfc_code2string (flavors
, attr
->flavor
),
999 gfc_code2string (flavors
, f
), where
);
1006 return check_conflict (attr
, name
, where
);
1011 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1012 const char *name
, locus
* where
)
1015 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1018 if (attr
->flavor
!= FL_PROCEDURE
1019 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1023 where
= &gfc_current_locus
;
1025 if (attr
->proc
!= PROC_UNKNOWN
)
1027 gfc_error ("%s procedure at %L is already declared as %s procedure",
1028 gfc_code2string (procedures
, t
), where
,
1029 gfc_code2string (procedures
, attr
->proc
));
1036 /* Statement functions are always scalar and functions. */
1037 if (t
== PROC_ST_FUNCTION
1038 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1039 || attr
->dimension
))
1042 return check_conflict (attr
, name
, where
);
1047 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1050 if (check_used (attr
, NULL
, where
))
1053 if (attr
->intent
== INTENT_UNKNOWN
)
1055 attr
->intent
= intent
;
1056 return check_conflict (attr
, NULL
, where
);
1060 where
= &gfc_current_locus
;
1062 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1063 gfc_intent_string (attr
->intent
),
1064 gfc_intent_string (intent
), where
);
1070 /* No checks for use-association in public and private statements. */
1073 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1074 const char *name
, locus
* where
)
1077 if (attr
->access
== ACCESS_UNKNOWN
)
1079 attr
->access
= access
;
1080 return check_conflict (attr
, name
, where
);
1084 where
= &gfc_current_locus
;
1085 gfc_error ("ACCESS specification at %L was already specified", where
);
1092 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1093 gfc_formal_arglist
* formal
, locus
* where
)
1096 if (check_used (&sym
->attr
, sym
->name
, where
))
1100 where
= &gfc_current_locus
;
1102 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1103 && sym
->attr
.if_source
!= IFSRC_DECL
)
1105 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1110 sym
->formal
= formal
;
1111 sym
->attr
.if_source
= source
;
1117 /* Add a type to a symbol. */
1120 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1124 /* TODO: This is legal if it is reaffirming an implicit type.
1125 if (check_done (&sym->attr, where))
1129 where
= &gfc_current_locus
;
1131 if (sym
->ts
.type
!= BT_UNKNOWN
)
1133 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1134 where
, gfc_basic_typename (sym
->ts
.type
));
1138 flavor
= sym
->attr
.flavor
;
1140 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1141 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1142 && sym
->attr
.subroutine
)
1143 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1145 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1154 /* Clears all attributes. */
1157 gfc_clear_attr (symbol_attribute
* attr
)
1159 memset (attr
, 0, sizeof(symbol_attribute
));
1163 /* Check for missing attributes in the new symbol. Currently does
1164 nothing, but it's not clear that it is unnecessary yet. */
1167 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1168 locus
* where ATTRIBUTE_UNUSED
)
1175 /* Copy an attribute to a symbol attribute, bit by bit. Some
1176 attributes have a lot of side-effects but cannot be present given
1177 where we are called from, so we ignore some bits. */
1180 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1183 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1186 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1188 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1190 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1192 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1194 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1196 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1198 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1203 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1206 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1209 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1211 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1213 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1216 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1218 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1220 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1222 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1225 if (src
->flavor
!= FL_UNKNOWN
1226 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1229 if (src
->intent
!= INTENT_UNKNOWN
1230 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1233 if (src
->access
!= ACCESS_UNKNOWN
1234 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1237 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1240 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1242 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1245 /* The subroutines that set these bits also cause flavors to be set,
1246 and that has already happened in the original, so don't let it
1251 dest
->intrinsic
= 1;
1260 /************** Component name management ************/
1262 /* Component names of a derived type form their own little namespaces
1263 that are separate from all other spaces. The space is composed of
1264 a singly linked list of gfc_component structures whose head is
1265 located in the parent symbol. */
1268 /* Add a component name to a symbol. The call fails if the name is
1269 already present. On success, the component pointer is modified to
1270 point to the additional component structure. */
1273 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1275 gfc_component
*p
, *tail
;
1279 for (p
= sym
->components
; p
; p
= p
->next
)
1281 if (strcmp (p
->name
, name
) == 0)
1283 gfc_error ("Component '%s' at %C already declared at %L",
1291 /* Allocate a new component. */
1292 p
= gfc_get_component ();
1295 sym
->components
= p
;
1299 p
->name
= gfc_get_string (name
);
1300 p
->loc
= gfc_current_locus
;
1307 /* Recursive function to switch derived types of all symbol in a
1311 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1319 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1320 sym
->ts
.derived
= to
;
1322 switch_types (st
->left
, from
, to
);
1323 switch_types (st
->right
, from
, to
);
1327 /* This subroutine is called when a derived type is used in order to
1328 make the final determination about which version to use. The
1329 standard requires that a type be defined before it is 'used', but
1330 such types can appear in IMPLICIT statements before the actual
1331 definition. 'Using' in this context means declaring a variable to
1332 be that type or using the type constructor.
1334 If a type is used and the components haven't been defined, then we
1335 have to have a derived type in a parent unit. We find the node in
1336 the other namespace and point the symtree node in this namespace to
1337 that node. Further reference to this name point to the correct
1338 node. If we can't find the node in a parent namespace, then we have
1341 This subroutine takes a pointer to a symbol node and returns a
1342 pointer to the translated node or NULL for an error. Usually there
1343 is no translation and we return the node we were passed. */
1346 gfc_use_derived (gfc_symbol
* sym
)
1353 if (sym
->components
!= NULL
)
1354 return sym
; /* Already defined. */
1356 if (sym
->ns
->parent
== NULL
)
1359 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1361 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1365 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1368 /* Get rid of symbol sym, translating all references to s. */
1369 for (i
= 0; i
< GFC_LETTERS
; i
++)
1371 t
= &sym
->ns
->default_type
[i
];
1372 if (t
->derived
== sym
)
1376 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1381 /* Unlink from list of modified symbols. */
1382 gfc_commit_symbol (sym
);
1384 switch_types (sym
->ns
->sym_root
, sym
, s
);
1386 /* TODO: Also have to replace sym -> s in other lists like
1387 namelists, common lists and interface lists. */
1388 gfc_free_symbol (sym
);
1393 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1399 /* Given a derived type node and a component name, try to locate the
1400 component structure. Returns the NULL pointer if the component is
1401 not found or the components are private. */
1404 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1411 sym
= gfc_use_derived (sym
);
1416 for (p
= sym
->components
; p
; p
= p
->next
)
1417 if (strcmp (p
->name
, name
) == 0)
1421 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1425 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1427 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1437 /* Given a symbol, free all of the component structures and everything
1441 free_components (gfc_component
* p
)
1449 gfc_free_array_spec (p
->as
);
1450 gfc_free_expr (p
->initializer
);
1457 /* Set component attributes from a standard symbol attribute
1461 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1464 c
->dimension
= attr
->dimension
;
1465 c
->pointer
= attr
->pointer
;
1469 /* Get a standard symbol attribute structure given the component
1473 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1476 gfc_clear_attr (attr
);
1477 attr
->dimension
= c
->dimension
;
1478 attr
->pointer
= c
->pointer
;
1482 /******************** Statement label management ********************/
1484 /* Comparison function for statement labels, used for managing the
1488 compare_st_labels (void * a1
, void * b1
)
1490 int a
= ((gfc_st_label
*)a1
)->value
;
1491 int b
= ((gfc_st_label
*)b1
)->value
;
1497 /* Free a single gfc_st_label structure, making sure the tree is not
1498 messed up. This function is called only when some parse error
1502 gfc_free_st_label (gfc_st_label
* label
)
1507 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1509 if (label
->format
!= NULL
)
1510 gfc_free_expr (label
->format
);
1515 /* Free a whole tree of gfc_st_label structures. */
1518 free_st_labels (gfc_st_label
* label
)
1523 free_st_labels (label
->left
);
1524 free_st_labels (label
->right
);
1526 if (label
->format
!= NULL
)
1527 gfc_free_expr (label
->format
);
1532 /* Given a label number, search for and return a pointer to the label
1533 structure, creating it if it does not exist. */
1536 gfc_get_st_label (int labelno
)
1540 /* First see if the label is already in this namespace. */
1541 lp
= gfc_current_ns
->st_labels
;
1544 if (lp
->value
== labelno
)
1547 if (lp
->value
< labelno
)
1553 lp
= gfc_getmem (sizeof (gfc_st_label
));
1555 lp
->value
= labelno
;
1556 lp
->defined
= ST_LABEL_UNKNOWN
;
1557 lp
->referenced
= ST_LABEL_UNKNOWN
;
1559 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1565 /* Called when a statement with a statement label is about to be
1566 accepted. We add the label to the list of the current namespace,
1567 making sure it hasn't been defined previously and referenced
1571 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1575 labelno
= lp
->value
;
1577 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1578 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1579 &lp
->where
, label_locus
);
1582 lp
->where
= *label_locus
;
1586 case ST_LABEL_FORMAT
:
1587 if (lp
->referenced
== ST_LABEL_TARGET
)
1588 gfc_error ("Label %d at %C already referenced as branch target",
1591 lp
->defined
= ST_LABEL_FORMAT
;
1595 case ST_LABEL_TARGET
:
1596 if (lp
->referenced
== ST_LABEL_FORMAT
)
1597 gfc_error ("Label %d at %C already referenced as a format label",
1600 lp
->defined
= ST_LABEL_TARGET
;
1605 lp
->defined
= ST_LABEL_BAD_TARGET
;
1606 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1612 /* Reference a label. Given a label and its type, see if that
1613 reference is consistent with what is known about that label,
1614 updating the unknown state. Returns FAILURE if something goes
1618 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1620 gfc_sl_type label_type
;
1627 labelno
= lp
->value
;
1629 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1630 label_type
= lp
->defined
;
1633 label_type
= lp
->referenced
;
1634 lp
->where
= gfc_current_locus
;
1637 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1639 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1644 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1645 && type
== ST_LABEL_FORMAT
)
1647 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1652 lp
->referenced
= type
;
1660 /************** Symbol table management subroutines ****************/
1662 /* Basic details: Fortran 95 requires a potentially unlimited number
1663 of distinct namespaces when compiling a program unit. This case
1664 occurs during a compilation of internal subprograms because all of
1665 the internal subprograms must be read before we can start
1666 generating code for the host.
1668 Given the tricky nature of the Fortran grammar, we must be able to
1669 undo changes made to a symbol table if the current interpretation
1670 of a statement is found to be incorrect. Whenever a symbol is
1671 looked up, we make a copy of it and link to it. All of these
1672 symbols are kept in a singly linked list so that we can commit or
1673 undo the changes at a later time.
1675 A symtree may point to a symbol node outside of its namespace. In
1676 this case, that symbol has been used as a host associated variable
1677 at some previous time. */
1679 /* Allocate a new namespace structure. Copies the implicit types from
1680 PARENT if PARENT_TYPES is set. */
1683 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1687 gfc_intrinsic_op in
;
1690 ns
= gfc_getmem (sizeof (gfc_namespace
));
1691 ns
->sym_root
= NULL
;
1692 ns
->uop_root
= NULL
;
1693 ns
->default_access
= ACCESS_UNKNOWN
;
1694 ns
->parent
= parent
;
1696 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1697 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1699 /* Initialize default implicit types. */
1700 for (i
= 'a'; i
<= 'z'; i
++)
1702 ns
->set_flag
[i
- 'a'] = 0;
1703 ts
= &ns
->default_type
[i
- 'a'];
1705 if (parent_types
&& ns
->parent
!= NULL
)
1707 /* Copy parent settings */
1708 *ts
= ns
->parent
->default_type
[i
- 'a'];
1712 if (gfc_option
.flag_implicit_none
!= 0)
1718 if ('i' <= i
&& i
<= 'n')
1720 ts
->type
= BT_INTEGER
;
1721 ts
->kind
= gfc_default_integer_kind
;
1726 ts
->kind
= gfc_default_real_kind
;
1736 /* Comparison function for symtree nodes. */
1739 compare_symtree (void * _st1
, void * _st2
)
1741 gfc_symtree
*st1
, *st2
;
1743 st1
= (gfc_symtree
*) _st1
;
1744 st2
= (gfc_symtree
*) _st2
;
1746 return strcmp (st1
->name
, st2
->name
);
1750 /* Allocate a new symtree node and associate it with the new symbol. */
1753 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1757 st
= gfc_getmem (sizeof (gfc_symtree
));
1758 st
->name
= gfc_get_string (name
);
1760 gfc_insert_bbt (root
, st
, compare_symtree
);
1765 /* Delete a symbol from the tree. Does not free the symbol itself! */
1768 delete_symtree (gfc_symtree
** root
, const char *name
)
1770 gfc_symtree st
, *st0
;
1772 st0
= gfc_find_symtree (*root
, name
);
1774 st
.name
= gfc_get_string (name
);
1775 gfc_delete_bbt (root
, &st
, compare_symtree
);
1781 /* Given a root symtree node and a name, try to find the symbol within
1782 the namespace. Returns NULL if the symbol is not found. */
1785 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1791 c
= strcmp (name
, st
->name
);
1795 st
= (c
< 0) ? st
->left
: st
->right
;
1802 /* Given a name find a user operator node, creating it if it doesn't
1803 exist. These are much simpler than symbols because they can't be
1804 ambiguous with one another. */
1807 gfc_get_uop (const char *name
)
1812 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
1816 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
1818 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
1819 uop
->name
= gfc_get_string (name
);
1820 uop
->access
= ACCESS_UNKNOWN
;
1821 uop
->ns
= gfc_current_ns
;
1827 /* Given a name find the user operator node. Returns NULL if it does
1831 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
1836 ns
= gfc_current_ns
;
1838 st
= gfc_find_symtree (ns
->uop_root
, name
);
1839 return (st
== NULL
) ? NULL
: st
->n
.uop
;
1843 /* Remove a gfc_symbol structure and everything it points to. */
1846 gfc_free_symbol (gfc_symbol
* sym
)
1852 gfc_free_array_spec (sym
->as
);
1854 free_components (sym
->components
);
1856 gfc_free_expr (sym
->value
);
1858 gfc_free_namelist (sym
->namelist
);
1860 gfc_free_namespace (sym
->formal_ns
);
1862 gfc_free_interface (sym
->generic
);
1864 gfc_free_formal_arglist (sym
->formal
);
1870 /* Allocate and initialize a new symbol node. */
1873 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
1877 p
= gfc_getmem (sizeof (gfc_symbol
));
1879 gfc_clear_ts (&p
->ts
);
1880 gfc_clear_attr (&p
->attr
);
1883 p
->declared_at
= gfc_current_locus
;
1885 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
1886 gfc_internal_error ("new_symbol(): Symbol name too long");
1888 p
->name
= gfc_get_string (name
);
1893 /* Generate an error if a symbol is ambiguous. */
1896 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
1899 if (st
->n
.sym
->module
)
1900 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1901 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
1903 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
1904 "from current program unit", name
, st
->n
.sym
->name
);
1908 /* Search for a symtree starting in the current namespace, resorting to
1909 any parent namespaces if requested by a nonzero parent_flag.
1910 Returns nonzero if the name is ambiguous. */
1913 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1914 gfc_symtree
** result
)
1919 ns
= gfc_current_ns
;
1923 st
= gfc_find_symtree (ns
->sym_root
, name
);
1929 ambiguous_symbol (name
, st
);
1948 /* Same, but returns the symbol instead. */
1951 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
1952 gfc_symbol
** result
)
1957 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
1962 *result
= st
->n
.sym
;
1968 /* Save symbol with the information necessary to back it out. */
1971 save_symbol_data (gfc_symbol
* sym
)
1974 if (sym
->new || sym
->old_symbol
!= NULL
)
1977 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
1978 *(sym
->old_symbol
) = *sym
;
1980 sym
->tlink
= changed_syms
;
1985 /* Given a name, find a symbol, or create it if it does not exist yet
1986 in the current namespace. If the symbol is found we make sure that
1989 The integer return code indicates
1991 1 The symbol name was ambiguous
1992 2 The name meant to be established was already host associated.
1994 So if the return value is nonzero, then an error was issued. */
1997 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2002 /* This doesn't usually happen during resolution. */
2004 ns
= gfc_current_ns
;
2006 /* Try to find the symbol in ns. */
2007 st
= gfc_find_symtree (ns
->sym_root
, name
);
2011 /* If not there, create a new symbol. */
2012 p
= gfc_new_symbol (name
, ns
);
2014 /* Add to the list of tentative symbols. */
2015 p
->old_symbol
= NULL
;
2016 p
->tlink
= changed_syms
;
2021 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2028 /* Make sure the existing symbol is OK. */
2031 ambiguous_symbol (name
, st
);
2037 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2039 /* Symbol is from another namespace. */
2040 gfc_error ("Symbol '%s' at %C has already been host associated",
2047 /* Copy in case this symbol is changed. */
2048 save_symbol_data (p
);
2057 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2063 i
= gfc_get_sym_tree (name
, ns
, &st
);
2068 *result
= st
->n
.sym
;
2075 /* Subroutine that searches for a symbol, creating it if it doesn't
2076 exist, but tries to host-associate the symbol if possible. */
2079 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2084 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2087 save_symbol_data (st
->n
.sym
);
2093 if (gfc_current_ns
->parent
!= NULL
)
2095 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2106 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2111 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2116 i
= gfc_get_ha_sym_tree (name
, &st
);
2119 *result
= st
->n
.sym
;
2126 /* Return true if both symbols could refer to the same data object. Does
2127 not take account of aliasing due to equivalence statements. */
2130 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2132 /* Aliasing isn't possible if the symbols have different base types. */
2133 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2136 /* Pointers can point to other pointers, target objects and allocatable
2137 objects. Two allocatable objects cannot share the same storage. */
2138 if (lsym
->attr
.pointer
2139 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2141 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2143 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2150 /* Undoes all the changes made to symbols in the current statement.
2151 This subroutine is made simpler due to the fact that attributes are
2152 never removed once added. */
2155 gfc_undo_symbols (void)
2157 gfc_symbol
*p
, *q
, *old
;
2159 for (p
= changed_syms
; p
; p
= q
)
2165 /* Symbol was new. */
2166 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2170 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2172 gfc_free_symbol (p
);
2176 /* Restore previous state of symbol. Just copy simple stuff. */
2178 old
= p
->old_symbol
;
2180 p
->ts
.type
= old
->ts
.type
;
2181 p
->ts
.kind
= old
->ts
.kind
;
2183 p
->attr
= old
->attr
;
2185 if (p
->value
!= old
->value
)
2187 gfc_free_expr (old
->value
);
2191 if (p
->as
!= old
->as
)
2194 gfc_free_array_spec (p
->as
);
2198 p
->generic
= old
->generic
;
2199 p
->component_access
= old
->component_access
;
2201 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2203 gfc_free_namelist (p
->namelist
);
2209 if (p
->namelist_tail
!= old
->namelist_tail
)
2211 gfc_free_namelist (old
->namelist_tail
);
2212 old
->namelist_tail
->next
= NULL
;
2216 p
->namelist_tail
= old
->namelist_tail
;
2218 if (p
->formal
!= old
->formal
)
2220 gfc_free_formal_arglist (p
->formal
);
2221 p
->formal
= old
->formal
;
2224 gfc_free (p
->old_symbol
);
2225 p
->old_symbol
= NULL
;
2229 changed_syms
= NULL
;
2233 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; but
2234 few components might have been given new values. */
2237 free_old_symbol (gfc_symbol
* sym
)
2239 if (sym
->old_symbol
== NULL
)
2242 if (sym
->old_symbol
->as
!= sym
->as
)
2243 gfc_free_array_spec (sym
->old_symbol
->as
);
2245 if (sym
->old_symbol
->value
!= sym
->value
)
2246 gfc_free_expr (sym
->old_symbol
->value
);
2248 gfc_free (sym
->old_symbol
);
2249 sym
->old_symbol
= NULL
;
2253 /* Makes the changes made in the current statement permanent-- gets
2254 rid of undo information. */
2257 gfc_commit_symbols (void)
2261 for (p
= changed_syms
; p
; p
= q
)
2268 free_old_symbol (p
);
2270 changed_syms
= NULL
;
2274 /* Makes the changes made in one symbol permanent -- gets rid of undo
2278 gfc_commit_symbol (gfc_symbol
* sym
)
2282 if (changed_syms
== sym
)
2283 changed_syms
= sym
->tlink
;
2286 for (p
= changed_syms
; p
; p
= p
->tlink
)
2287 if (p
->tlink
== sym
)
2289 p
->tlink
= sym
->tlink
;
2298 free_old_symbol (sym
);
2302 /* Recursive function that deletes an entire tree and all the common
2303 head structures it points to. */
2306 free_common_tree (gfc_symtree
* common_tree
)
2308 if (common_tree
== NULL
)
2311 free_common_tree (common_tree
->left
);
2312 free_common_tree (common_tree
->right
);
2314 gfc_free (common_tree
);
2318 /* Recursive function that deletes an entire tree and all the user
2319 operator nodes that it contains. */
2322 free_uop_tree (gfc_symtree
* uop_tree
)
2325 if (uop_tree
== NULL
)
2328 free_uop_tree (uop_tree
->left
);
2329 free_uop_tree (uop_tree
->right
);
2331 gfc_free_interface (uop_tree
->n
.uop
->operator);
2333 gfc_free (uop_tree
->n
.uop
);
2334 gfc_free (uop_tree
);
2338 /* Recursive function that deletes an entire tree and all the symbols
2339 that it contains. */
2342 free_sym_tree (gfc_symtree
* sym_tree
)
2347 if (sym_tree
== NULL
)
2350 free_sym_tree (sym_tree
->left
);
2351 free_sym_tree (sym_tree
->right
);
2353 sym
= sym_tree
->n
.sym
;
2357 gfc_internal_error ("free_sym_tree(): Negative refs");
2359 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2361 /* As formal_ns contains a reference to sym, delete formal_ns just
2362 before the deletion of sym. */
2363 ns
= sym
->formal_ns
;
2364 sym
->formal_ns
= NULL
;
2365 gfc_free_namespace (ns
);
2367 else if (sym
->refs
== 0)
2369 /* Go ahead and delete the symbol. */
2370 gfc_free_symbol (sym
);
2373 gfc_free (sym_tree
);
2377 /* Free a derived type list. */
2380 gfc_free_dt_list (gfc_dt_list
* dt
)
2392 /* Free a namespace structure and everything below it. Interface
2393 lists associated with intrinsic operators are not freed. These are
2394 taken care of when a specific name is freed. */
2397 gfc_free_namespace (gfc_namespace
* ns
)
2399 gfc_charlen
*cl
, *cl2
;
2400 gfc_namespace
*p
, *q
;
2409 gcc_assert (ns
->refs
== 0);
2411 gfc_free_statements (ns
->code
);
2413 free_sym_tree (ns
->sym_root
);
2414 free_uop_tree (ns
->uop_root
);
2415 free_common_tree (ns
->common_root
);
2417 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2420 gfc_free_expr (cl
->length
);
2424 free_st_labels (ns
->st_labels
);
2426 gfc_free_equiv (ns
->equiv
);
2428 gfc_free_dt_list (ns
->derived_types
);
2430 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2431 gfc_free_interface (ns
->operator[i
]);
2433 gfc_free_data (ns
->data
);
2437 /* Recursively free any contained namespaces. */
2443 gfc_free_namespace (q
);
2449 gfc_symbol_init_2 (void)
2452 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2457 gfc_symbol_done_2 (void)
2460 gfc_free_namespace (gfc_current_ns
);
2461 gfc_current_ns
= NULL
;
2465 /* Clear mark bits from symbol nodes associated with a symtree node. */
2468 clear_sym_mark (gfc_symtree
* st
)
2471 st
->n
.sym
->mark
= 0;
2475 /* Recursively traverse the symtree nodes. */
2478 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2484 gfc_traverse_symtree (st
->left
, func
);
2485 gfc_traverse_symtree (st
->right
, func
);
2490 /* Recursive namespace traversal function. */
2493 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2499 if (st
->n
.sym
->mark
== 0)
2500 (*func
) (st
->n
.sym
);
2501 st
->n
.sym
->mark
= 1;
2503 traverse_ns (st
->left
, func
);
2504 traverse_ns (st
->right
, func
);
2508 /* Call a given function for all symbols in the namespace. We take
2509 care that each gfc_symbol node is called exactly once. */
2512 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2515 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2517 traverse_ns (ns
->sym_root
, func
);
2521 /* Return TRUE if the symbol is an automatic variable. */
2523 gfc_is_var_automatic (gfc_symbol
* sym
)
2525 /* Pointer and allocatable variables are never automatic. */
2526 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2528 /* Check for arrays with non-constant size. */
2529 if (sym
->attr
.dimension
&& sym
->as
2530 && !gfc_is_compile_time_shape (sym
->as
))
2532 /* Check for non-constant length character variables. */
2533 if (sym
->ts
.type
== BT_CHARACTER
2535 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2540 /* Given a symbol, mark it as SAVEd if it is allowed. */
2543 save_symbol (gfc_symbol
* sym
)
2546 if (sym
->attr
.use_assoc
)
2549 if (sym
->attr
.in_common
2551 || sym
->attr
.flavor
!= FL_VARIABLE
)
2553 /* Automatic objects are not saved. */
2554 if (gfc_is_var_automatic (sym
))
2556 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2560 /* Mark those symbols which can be SAVEd as such. */
2563 gfc_save_all (gfc_namespace
* ns
)
2566 gfc_traverse_ns (ns
, save_symbol
);
2571 /* Make sure that no changes to symbols are pending. */
2574 gfc_symbol_state(void) {
2576 if (changed_syms
!= NULL
)
2577 gfc_internal_error("Symbol changes still pending!");
2582 /************** Global symbol handling ************/
2585 /* Search a tree for the global symbol. */
2588 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2594 if (strcmp (symbol
->name
, name
) == 0)
2597 s
= gfc_find_gsymbol (symbol
->left
, name
);
2601 s
= gfc_find_gsymbol (symbol
->right
, name
);
2609 /* Compare two global symbols. Used for managing the BB tree. */
2612 gsym_compare (void * _s1
, void * _s2
)
2614 gfc_gsymbol
*s1
, *s2
;
2616 s1
= (gfc_gsymbol
*)_s1
;
2617 s2
= (gfc_gsymbol
*)_s2
;
2618 return strcmp(s1
->name
, s2
->name
);
2622 /* Get a global symbol, creating it if it doesn't exist. */
2625 gfc_get_gsymbol (const char *name
)
2629 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2633 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2634 s
->type
= GSYM_UNKNOWN
;
2635 s
->name
= gfc_get_string (name
);
2637 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);