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
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
82 /* This is to make sure the backend generates setup code in the correct
85 static int next_dummy_order
= 1;
88 gfc_namespace
*gfc_current_ns
;
90 gfc_gsymbol
*gfc_gsym_root
= NULL
;
92 static gfc_symbol
*changed_syms
= NULL
;
95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
97 /* The following static variable indicates whether a particular element has
98 been explicitly set or not. */
100 static int new_flag
[GFC_LETTERS
];
103 /* Handle a correctly parsed IMPLICIT NONE. */
106 gfc_set_implicit_none (void)
110 if (gfc_current_ns
->seen_implicit_none
)
112 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
116 gfc_current_ns
->seen_implicit_none
= 1;
118 for (i
= 0; i
< GFC_LETTERS
; i
++)
120 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
121 gfc_current_ns
->set_flag
[i
] = 1;
126 /* Reset the implicit range flags. */
129 gfc_clear_new_implicit (void)
133 for (i
= 0; i
< GFC_LETTERS
; i
++)
138 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
141 gfc_add_new_implicit_range (int c1
, int c2
)
148 for (i
= c1
; i
<= c2
; i
++)
152 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
165 the new implicit types back into the existing types will work. */
168 gfc_merge_new_implicit (gfc_typespec
* ts
)
172 if (gfc_current_ns
->seen_implicit_none
)
174 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
178 for (i
= 0; i
< GFC_LETTERS
; i
++)
183 if (gfc_current_ns
->set_flag
[i
])
185 gfc_error ("Letter %c already has an IMPLICIT type at %C",
189 gfc_current_ns
->default_type
[i
] = *ts
;
190 gfc_current_ns
->set_flag
[i
] = 1;
197 /* Given a symbol, return a pointer to the typespec for its default type. */
200 gfc_get_default_type (gfc_symbol
* sym
, gfc_namespace
* ns
)
204 letter
= sym
->name
[0];
205 if (letter
< 'a' || letter
> 'z')
206 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
211 return &ns
->default_type
[letter
- 'a'];
215 /* Given a pointer to a symbol, set its type according to the first
216 letter of its name. Fails if the letter in question has no default
220 gfc_set_default_type (gfc_symbol
* sym
, int error_flag
, gfc_namespace
* ns
)
224 if (sym
->ts
.type
!= BT_UNKNOWN
)
225 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
227 ts
= gfc_get_default_type (sym
, ns
);
229 if (ts
->type
== BT_UNKNOWN
)
231 if (error_flag
&& !sym
->attr
.untyped
)
233 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
234 sym
->name
, &sym
->declared_at
);
235 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
242 sym
->attr
.implicit_type
= 1;
248 /******************** Symbol attribute stuff *********************/
250 /* This is a generic conflict-checker. We do this to avoid having a
251 single conflict in two places. */
253 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
254 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
255 #define conf_std(a, b, std) if (attr->a && attr->b)\
264 check_conflict (symbol_attribute
* attr
, const char * name
, locus
* where
)
266 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
267 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
268 *intrinsic
= "INTRINSIC", *allocatable
= "ALLOCATABLE",
269 *elemental
= "ELEMENTAL", *private = "PRIVATE", *recursive
= "RECURSIVE",
270 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
271 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
272 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
273 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
274 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
275 *cray_pointee
= "CRAY POINTEE", *data
= "DATA";
276 static const char *threadprivate
= "THREADPRIVATE";
282 where
= &gfc_current_locus
;
284 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
291 /* Check for attributes not allowed in a BLOCK DATA. */
292 if (gfc_current_state () == COMP_BLOCK_DATA
)
296 if (attr
->in_namelist
)
298 if (attr
->allocatable
)
304 if (attr
->access
== ACCESS_PRIVATE
)
306 if (attr
->access
== ACCESS_PUBLIC
)
308 if (attr
->intent
!= INTENT_UNKNOWN
)
314 ("%s attribute not allowed in BLOCK DATA program unit at %L", a1
,
321 conf (dummy
, threadprivate
);
322 conf (pointer
, target
);
323 conf (pointer
, external
);
324 conf (pointer
, intrinsic
);
325 conf (pointer
, elemental
);
326 conf (allocatable
, elemental
);
328 conf (target
, external
);
329 conf (target
, intrinsic
);
330 conf (external
, dimension
); /* See Fortran 95's R504. */
332 conf (external
, intrinsic
);
334 if (attr
->if_source
|| attr
->contained
)
336 conf (external
, subroutine
);
337 conf (external
, function
);
340 conf (allocatable
, pointer
);
341 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
342 conf_std (allocatable
, function
, GFC_STD_F2003
);
343 conf_std (allocatable
, result
, GFC_STD_F2003
);
344 conf (elemental
, recursive
);
346 conf (in_common
, dummy
);
347 conf (in_common
, allocatable
);
348 conf (in_common
, result
);
349 conf (in_common
, save
);
352 conf (dummy
, result
);
354 conf (in_equivalence
, use_assoc
);
355 conf (in_equivalence
, dummy
);
356 conf (in_equivalence
, target
);
357 conf (in_equivalence
, pointer
);
358 conf (in_equivalence
, function
);
359 conf (in_equivalence
, result
);
360 conf (in_equivalence
, entry
);
361 conf (in_equivalence
, allocatable
);
362 conf (in_equivalence
, threadprivate
);
364 conf (in_namelist
, pointer
);
365 conf (in_namelist
, allocatable
);
367 conf (entry
, result
);
369 conf (function
, subroutine
);
371 /* Cray pointer/pointee conflicts. */
372 conf (cray_pointer
, cray_pointee
);
373 conf (cray_pointer
, dimension
);
374 conf (cray_pointer
, pointer
);
375 conf (cray_pointer
, target
);
376 conf (cray_pointer
, allocatable
);
377 conf (cray_pointer
, external
);
378 conf (cray_pointer
, intrinsic
);
379 conf (cray_pointer
, in_namelist
);
380 conf (cray_pointer
, function
);
381 conf (cray_pointer
, subroutine
);
382 conf (cray_pointer
, entry
);
384 conf (cray_pointee
, allocatable
);
385 conf (cray_pointee
, intent
);
386 conf (cray_pointee
, optional
);
387 conf (cray_pointee
, dummy
);
388 conf (cray_pointee
, target
);
389 conf (cray_pointee
, intrinsic
);
390 conf (cray_pointee
, pointer
);
391 conf (cray_pointee
, entry
);
392 conf (cray_pointee
, in_common
);
393 conf (cray_pointee
, in_equivalence
);
394 conf (cray_pointee
, threadprivate
);
397 conf (data
, function
);
399 conf (data
, allocatable
);
400 conf (data
, use_assoc
);
402 a1
= gfc_code2string (flavors
, attr
->flavor
);
404 if (attr
->in_namelist
405 && attr
->flavor
!= FL_VARIABLE
406 && attr
->flavor
!= FL_UNKNOWN
)
413 switch (attr
->flavor
)
431 conf2 (threadprivate
);
441 if (attr
->subroutine
)
450 conf2(threadprivate
);
455 case PROC_ST_FUNCTION
:
468 conf2 (threadprivate
);
489 conf2 (threadprivate
);
491 if (attr
->intent
!= INTENT_UNKNOWN
)
511 conf2 (threadprivate
);
522 gfc_error ("%s attribute conflicts with %s attribute at %L",
525 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
526 a1
, a2
, name
, where
);
533 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
534 "conflicts with %s attribute at %L", a1
, a2
,
539 return gfc_notify_std (standard
, "In the selected standard, %s attribute "
540 "conflicts with %s attribute in '%s' at %L",
541 a1
, a2
, name
, where
);
550 /* Mark a symbol as referenced. */
553 gfc_set_sym_referenced (gfc_symbol
* sym
)
555 if (sym
->attr
.referenced
)
558 sym
->attr
.referenced
= 1;
560 /* Remember which order dummy variables are accessed in. */
562 sym
->dummy_order
= next_dummy_order
++;
566 /* Common subroutine called by attribute changing subroutines in order
567 to prevent them from changing a symbol that has been
568 use-associated. Returns zero if it is OK to change the symbol,
572 check_used (symbol_attribute
* attr
, const char * name
, locus
* where
)
575 if (attr
->use_assoc
== 0)
579 where
= &gfc_current_locus
;
582 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
585 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
592 /* Used to prevent changing the attributes of a symbol after it has been
593 used. This check is only done for dummy variables as only these can be
594 used in specification expressions. Applying this to all symbols causes
595 an error when we reach the body of a contained function. */
598 check_done (symbol_attribute
* attr
, locus
* where
)
601 if (!(attr
->dummy
&& attr
->referenced
))
605 where
= &gfc_current_locus
;
607 gfc_error ("Cannot change attributes of symbol at %L"
608 " after it has been used", where
);
614 /* Generate an error because of a duplicate attribute. */
617 duplicate_attr (const char *attr
, locus
* where
)
621 where
= &gfc_current_locus
;
623 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
626 /* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
629 gfc_add_attribute (symbol_attribute
* attr
, locus
* where
,
630 unsigned int attr_intent
)
633 if (check_used (attr
, NULL
, where
)
634 || (attr_intent
== 0 && check_done (attr
, where
)))
637 return check_conflict (attr
, NULL
, where
);
641 gfc_add_allocatable (symbol_attribute
* attr
, locus
* where
)
644 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
647 if (attr
->allocatable
)
649 duplicate_attr ("ALLOCATABLE", where
);
653 attr
->allocatable
= 1;
654 return check_conflict (attr
, NULL
, where
);
659 gfc_add_dimension (symbol_attribute
* attr
, const char *name
, locus
* where
)
662 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
667 duplicate_attr ("DIMENSION", where
);
672 return check_conflict (attr
, name
, where
);
677 gfc_add_external (symbol_attribute
* attr
, locus
* where
)
680 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
685 duplicate_attr ("EXTERNAL", where
);
691 return check_conflict (attr
, NULL
, where
);
696 gfc_add_intrinsic (symbol_attribute
* attr
, locus
* where
)
699 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
704 duplicate_attr ("INTRINSIC", where
);
710 return check_conflict (attr
, NULL
, where
);
715 gfc_add_optional (symbol_attribute
* attr
, locus
* where
)
718 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
723 duplicate_attr ("OPTIONAL", where
);
728 return check_conflict (attr
, NULL
, where
);
733 gfc_add_pointer (symbol_attribute
* attr
, locus
* where
)
736 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
740 return check_conflict (attr
, NULL
, where
);
745 gfc_add_cray_pointer (symbol_attribute
* attr
, locus
* where
)
748 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
751 attr
->cray_pointer
= 1;
752 return check_conflict (attr
, NULL
, where
);
757 gfc_add_cray_pointee (symbol_attribute
* attr
, locus
* where
)
760 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
763 if (attr
->cray_pointee
)
765 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
766 " statements.", where
);
770 attr
->cray_pointee
= 1;
771 return check_conflict (attr
, NULL
, where
);
776 gfc_add_result (symbol_attribute
* attr
, const char *name
, locus
* where
)
779 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
783 return check_conflict (attr
, name
, where
);
788 gfc_add_save (symbol_attribute
* attr
, const char *name
, locus
* where
)
791 if (check_used (attr
, name
, where
))
797 ("SAVE attribute at %L cannot be specified in a PURE procedure",
804 if (gfc_notify_std (GFC_STD_LEGACY
,
805 "Duplicate SAVE attribute specified at %L",
812 return check_conflict (attr
, name
, where
);
817 gfc_add_threadprivate (symbol_attribute
* attr
, const char *name
, locus
* where
)
819 if (check_used (attr
, name
, where
))
822 if (attr
->threadprivate
)
824 duplicate_attr ("THREADPRIVATE", where
);
828 attr
->threadprivate
= 1;
829 return check_conflict (attr
, name
, where
);
834 gfc_add_target (symbol_attribute
* attr
, locus
* where
)
837 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
842 duplicate_attr ("TARGET", where
);
847 return check_conflict (attr
, NULL
, where
);
852 gfc_add_dummy (symbol_attribute
* attr
, const char *name
, locus
* where
)
855 if (check_used (attr
, name
, where
))
858 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
860 return check_conflict (attr
, name
, where
);
865 gfc_add_in_common (symbol_attribute
* attr
, const char *name
, locus
* where
)
868 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
871 /* Duplicate attribute already checked for. */
873 if (check_conflict (attr
, name
, where
) == FAILURE
)
876 if (attr
->flavor
== FL_VARIABLE
)
879 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
883 gfc_add_in_equivalence (symbol_attribute
* attr
, const char *name
, locus
* where
)
886 /* Duplicate attribute already checked for. */
887 attr
->in_equivalence
= 1;
888 if (check_conflict (attr
, name
, where
) == FAILURE
)
891 if (attr
->flavor
== FL_VARIABLE
)
894 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
899 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
902 if (check_used (attr
, name
, where
))
906 return check_conflict (attr
, name
, where
);
911 gfc_add_in_namelist (symbol_attribute
* attr
, const char *name
,
915 attr
->in_namelist
= 1;
916 return check_conflict (attr
, name
, where
);
921 gfc_add_sequence (symbol_attribute
* attr
, const char *name
, locus
* where
)
924 if (check_used (attr
, name
, where
))
928 return check_conflict (attr
, name
, where
);
933 gfc_add_elemental (symbol_attribute
* attr
, locus
* where
)
936 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
940 return check_conflict (attr
, NULL
, where
);
945 gfc_add_pure (symbol_attribute
* attr
, locus
* where
)
948 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
952 return check_conflict (attr
, NULL
, where
);
957 gfc_add_recursive (symbol_attribute
* attr
, locus
* where
)
960 if (check_used (attr
, NULL
, where
) || check_done (attr
, where
))
964 return check_conflict (attr
, NULL
, where
);
969 gfc_add_entry (symbol_attribute
* attr
, const char *name
, locus
* where
)
972 if (check_used (attr
, name
, where
))
977 duplicate_attr ("ENTRY", where
);
982 return check_conflict (attr
, name
, where
);
987 gfc_add_function (symbol_attribute
* attr
, const char *name
, locus
* where
)
990 if (attr
->flavor
!= FL_PROCEDURE
991 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
995 return check_conflict (attr
, name
, where
);
1000 gfc_add_subroutine (symbol_attribute
* attr
, const char *name
, locus
* where
)
1003 if (attr
->flavor
!= FL_PROCEDURE
1004 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1007 attr
->subroutine
= 1;
1008 return check_conflict (attr
, name
, where
);
1013 gfc_add_generic (symbol_attribute
* attr
, const char *name
, locus
* where
)
1016 if (attr
->flavor
!= FL_PROCEDURE
1017 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1021 return check_conflict (attr
, name
, where
);
1025 /* Flavors are special because some flavors are not what Fortran
1026 considers attributes and can be reaffirmed multiple times. */
1029 gfc_add_flavor (symbol_attribute
* attr
, sym_flavor f
, const char *name
,
1033 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1034 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1035 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1038 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1041 if (attr
->flavor
!= FL_UNKNOWN
)
1044 where
= &gfc_current_locus
;
1046 gfc_error ("%s attribute conflicts with %s attribute at %L",
1047 gfc_code2string (flavors
, attr
->flavor
),
1048 gfc_code2string (flavors
, f
), where
);
1055 return check_conflict (attr
, name
, where
);
1060 gfc_add_procedure (symbol_attribute
* attr
, procedure_type t
,
1061 const char *name
, locus
* where
)
1064 if (check_used (attr
, name
, where
) || check_done (attr
, where
))
1067 if (attr
->flavor
!= FL_PROCEDURE
1068 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1072 where
= &gfc_current_locus
;
1074 if (attr
->proc
!= PROC_UNKNOWN
)
1076 gfc_error ("%s procedure at %L is already declared as %s procedure",
1077 gfc_code2string (procedures
, t
), where
,
1078 gfc_code2string (procedures
, attr
->proc
));
1085 /* Statement functions are always scalar and functions. */
1086 if (t
== PROC_ST_FUNCTION
1087 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1088 || attr
->dimension
))
1091 return check_conflict (attr
, name
, where
);
1096 gfc_add_intent (symbol_attribute
* attr
, sym_intent intent
, locus
* where
)
1099 if (check_used (attr
, NULL
, where
))
1102 if (attr
->intent
== INTENT_UNKNOWN
)
1104 attr
->intent
= intent
;
1105 return check_conflict (attr
, NULL
, where
);
1109 where
= &gfc_current_locus
;
1111 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1112 gfc_intent_string (attr
->intent
),
1113 gfc_intent_string (intent
), where
);
1119 /* No checks for use-association in public and private statements. */
1122 gfc_add_access (symbol_attribute
* attr
, gfc_access access
,
1123 const char *name
, locus
* where
)
1126 if (attr
->access
== ACCESS_UNKNOWN
)
1128 attr
->access
= access
;
1129 return check_conflict (attr
, name
, where
);
1133 where
= &gfc_current_locus
;
1134 gfc_error ("ACCESS specification at %L was already specified", where
);
1141 gfc_add_explicit_interface (gfc_symbol
* sym
, ifsrc source
,
1142 gfc_formal_arglist
* formal
, locus
* where
)
1145 if (check_used (&sym
->attr
, sym
->name
, where
))
1149 where
= &gfc_current_locus
;
1151 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1152 && sym
->attr
.if_source
!= IFSRC_DECL
)
1154 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1159 sym
->formal
= formal
;
1160 sym
->attr
.if_source
= source
;
1166 /* Add a type to a symbol. */
1169 gfc_add_type (gfc_symbol
* sym
, gfc_typespec
* ts
, locus
* where
)
1173 /* TODO: This is legal if it is reaffirming an implicit type.
1174 if (check_done (&sym->attr, where))
1178 where
= &gfc_current_locus
;
1180 if (sym
->ts
.type
!= BT_UNKNOWN
)
1182 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1183 if (!(sym
->ts
.type
== ts
->type
1184 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1185 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1188 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1191 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1192 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1196 flavor
= sym
->attr
.flavor
;
1198 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1199 || flavor
== FL_LABEL
|| (flavor
== FL_PROCEDURE
1200 && sym
->attr
.subroutine
)
1201 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1203 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1212 /* Clears all attributes. */
1215 gfc_clear_attr (symbol_attribute
* attr
)
1217 memset (attr
, 0, sizeof(symbol_attribute
));
1221 /* Check for missing attributes in the new symbol. Currently does
1222 nothing, but it's not clear that it is unnecessary yet. */
1225 gfc_missing_attr (symbol_attribute
* attr ATTRIBUTE_UNUSED
,
1226 locus
* where ATTRIBUTE_UNUSED
)
1233 /* Copy an attribute to a symbol attribute, bit by bit. Some
1234 attributes have a lot of side-effects but cannot be present given
1235 where we are called from, so we ignore some bits. */
1238 gfc_copy_attr (symbol_attribute
* dest
, symbol_attribute
* src
, locus
* where
)
1241 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1244 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1246 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1248 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1250 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1252 if (src
->threadprivate
&& gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1254 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1256 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1258 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1263 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1266 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1269 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1271 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1273 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1276 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1278 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1280 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1282 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1285 if (src
->flavor
!= FL_UNKNOWN
1286 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1289 if (src
->intent
!= INTENT_UNKNOWN
1290 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1293 if (src
->access
!= ACCESS_UNKNOWN
1294 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1297 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1300 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1302 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1305 /* The subroutines that set these bits also cause flavors to be set,
1306 and that has already happened in the original, so don't let it
1311 dest
->intrinsic
= 1;
1320 /************** Component name management ************/
1322 /* Component names of a derived type form their own little namespaces
1323 that are separate from all other spaces. The space is composed of
1324 a singly linked list of gfc_component structures whose head is
1325 located in the parent symbol. */
1328 /* Add a component name to a symbol. The call fails if the name is
1329 already present. On success, the component pointer is modified to
1330 point to the additional component structure. */
1333 gfc_add_component (gfc_symbol
* sym
, const char *name
, gfc_component
** component
)
1335 gfc_component
*p
, *tail
;
1339 for (p
= sym
->components
; p
; p
= p
->next
)
1341 if (strcmp (p
->name
, name
) == 0)
1343 gfc_error ("Component '%s' at %C already declared at %L",
1351 /* Allocate a new component. */
1352 p
= gfc_get_component ();
1355 sym
->components
= p
;
1359 p
->name
= gfc_get_string (name
);
1360 p
->loc
= gfc_current_locus
;
1367 /* Recursive search for a renamed derived type. */
1370 find_renamed_type (gfc_symbol
* der
, gfc_symtree
* st
)
1372 gfc_symbol
*sym
= NULL
;
1377 sym
= find_renamed_type (der
, st
->left
);
1381 sym
= find_renamed_type (der
, st
->right
);
1385 if (strcmp (der
->name
, st
->n
.sym
->name
) == 0
1386 && st
->n
.sym
->attr
.use_assoc
1387 && st
->n
.sym
->attr
.flavor
== FL_DERIVED
1388 && gfc_compare_derived_types (der
, st
->n
.sym
))
1394 /* Recursive function to switch derived types of all symbols in a
1395 namespace. The formal namespaces contain references to derived
1396 types that can be left hanging by gfc_use_derived, so these must
1400 switch_types (gfc_symtree
* st
, gfc_symbol
* from
, gfc_symbol
* to
)
1408 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1409 sym
->ts
.derived
= to
;
1411 if (sym
->formal_ns
&& sym
->formal_ns
->sym_root
)
1412 switch_types (sym
->formal_ns
->sym_root
, from
, to
);
1414 switch_types (st
->left
, from
, to
);
1415 switch_types (st
->right
, from
, to
);
1419 /* This subroutine is called when a derived type is used in order to
1420 make the final determination about which version to use. The
1421 standard requires that a type be defined before it is 'used', but
1422 such types can appear in IMPLICIT statements before the actual
1423 definition. 'Using' in this context means declaring a variable to
1424 be that type or using the type constructor.
1426 If a type is used and the components haven't been defined, then we
1427 have to have a derived type in a parent unit. We find the node in
1428 the other namespace and point the symtree node in this namespace to
1429 that node. Further reference to this name point to the correct
1430 node. If we can't find the node in a parent namespace, then we have
1433 This subroutine takes a pointer to a symbol node and returns a
1434 pointer to the translated node or NULL for an error. Usually there
1435 is no translation and we return the node we were passed. */
1438 gfc_use_derived (gfc_symbol
* sym
)
1447 if (sym
->ns
->parent
== NULL
|| sym
->ns
!= gfc_current_ns
)
1449 /* Already defined in highest possible or sibling namespace. */
1450 if (sym
->components
!= NULL
)
1453 /* There is no scope for finding a definition elsewhere. */
1459 /* This type can only be locally associated. */
1460 if (!(sym
->attr
.use_assoc
|| sym
->attr
.sequence
))
1463 /* Derived types must be defined within an interface. */
1464 if (gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
1468 /* Look in parent namespace for a derived type of the same name. */
1469 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1471 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1475 /* Look in sibling namespaces for a derived type of the same name. */
1476 if (s
== NULL
&& sym
->attr
.use_assoc
&& sym
->ns
->sibling
)
1478 ns
= sym
->ns
->sibling
;
1479 for (; ns
; ns
= ns
->sibling
)
1485 if (gfc_find_symbol (sym
->name
, ns
, 1, &s
))
1487 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1491 if (s
!= NULL
&& s
->attr
.flavor
== FL_DERIVED
)
1496 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1498 /* Check to see if type has been renamed in parent namespace. */
1499 s
= find_renamed_type (sym
, sym
->ns
->parent
->sym_root
);
1501 goto return_use_assoc
;
1503 /* See if sym is identical to renamed, use-associated derived
1504 types in sibling namespaces. */
1505 if (sym
->attr
.use_assoc
1507 && sym
->ns
->parent
->contained
)
1509 ns
= sym
->ns
->parent
->contained
;
1510 for (; ns
; ns
= ns
->sibling
)
1515 s
= find_renamed_type (sym
, ns
->sym_root
);
1518 goto return_use_assoc
;
1522 /* The local definition is all that there is. */
1523 if (sym
->components
!= NULL
)
1525 /* Non-pointer derived type components have already been checked
1526 but pointer types need to be correctly associated. */
1527 for (c
= sym
->components
; c
; c
= c
->next
)
1528 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
)
1529 c
->ts
.derived
= gfc_use_derived (c
->ts
.derived
);
1535 /* Although the parent namespace has a derived type of the same name, it is
1536 not an identical derived type and so cannot be used. */
1537 if (s
!= NULL
&& sym
->components
!= NULL
&& !gfc_compare_derived_types (s
, sym
))
1540 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1543 /* Get rid of symbol sym, translating all references to s. */
1544 for (i
= 0; i
< GFC_LETTERS
; i
++)
1546 t
= &sym
->ns
->default_type
[i
];
1547 if (t
->derived
== sym
)
1551 if (sym
->attr
.use_assoc
)
1552 goto return_use_assoc
;
1554 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1559 /* Unlink from list of modified symbols. */
1560 gfc_commit_symbol (sym
);
1562 switch_types (sym
->ns
->sym_root
, sym
, s
);
1564 /* TODO: Also have to replace sym -> s in other lists like
1565 namelists, common lists and interface lists. */
1566 gfc_free_symbol (sym
);
1571 /* Use associated types are not freed at this stage because some
1572 references remain to 'sym'. We retain the symbol and leave it
1573 to be cleaned up by gfc_free_namespace, at the end of the
1575 switch_types (sym
->ns
->sym_root
, sym
, s
);
1579 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1585 /* Given a derived type node and a component name, try to locate the
1586 component structure. Returns the NULL pointer if the component is
1587 not found or the components are private. */
1590 gfc_find_component (gfc_symbol
* sym
, const char *name
)
1597 sym
= gfc_use_derived (sym
);
1602 for (p
= sym
->components
; p
; p
= p
->next
)
1603 if (strcmp (p
->name
, name
) == 0)
1607 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1611 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
1613 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1623 /* Given a symbol, free all of the component structures and everything
1627 free_components (gfc_component
* p
)
1635 gfc_free_array_spec (p
->as
);
1636 gfc_free_expr (p
->initializer
);
1643 /* Set component attributes from a standard symbol attribute
1647 gfc_set_component_attr (gfc_component
* c
, symbol_attribute
* attr
)
1650 c
->dimension
= attr
->dimension
;
1651 c
->pointer
= attr
->pointer
;
1655 /* Get a standard symbol attribute structure given the component
1659 gfc_get_component_attr (symbol_attribute
* attr
, gfc_component
* c
)
1662 gfc_clear_attr (attr
);
1663 attr
->dimension
= c
->dimension
;
1664 attr
->pointer
= c
->pointer
;
1668 /******************** Statement label management ********************/
1670 /* Comparison function for statement labels, used for managing the
1674 compare_st_labels (void * a1
, void * b1
)
1676 int a
= ((gfc_st_label
*)a1
)->value
;
1677 int b
= ((gfc_st_label
*)b1
)->value
;
1683 /* Free a single gfc_st_label structure, making sure the tree is not
1684 messed up. This function is called only when some parse error
1688 gfc_free_st_label (gfc_st_label
* label
)
1693 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1695 if (label
->format
!= NULL
)
1696 gfc_free_expr (label
->format
);
1701 /* Free a whole tree of gfc_st_label structures. */
1704 free_st_labels (gfc_st_label
* label
)
1709 free_st_labels (label
->left
);
1710 free_st_labels (label
->right
);
1712 if (label
->format
!= NULL
)
1713 gfc_free_expr (label
->format
);
1718 /* Given a label number, search for and return a pointer to the label
1719 structure, creating it if it does not exist. */
1722 gfc_get_st_label (int labelno
)
1726 /* First see if the label is already in this namespace. */
1727 lp
= gfc_current_ns
->st_labels
;
1730 if (lp
->value
== labelno
)
1733 if (lp
->value
< labelno
)
1739 lp
= gfc_getmem (sizeof (gfc_st_label
));
1741 lp
->value
= labelno
;
1742 lp
->defined
= ST_LABEL_UNKNOWN
;
1743 lp
->referenced
= ST_LABEL_UNKNOWN
;
1745 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1751 /* Called when a statement with a statement label is about to be
1752 accepted. We add the label to the list of the current namespace,
1753 making sure it hasn't been defined previously and referenced
1757 gfc_define_st_label (gfc_st_label
* lp
, gfc_sl_type type
, locus
* label_locus
)
1761 labelno
= lp
->value
;
1763 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1764 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1765 &lp
->where
, label_locus
);
1768 lp
->where
= *label_locus
;
1772 case ST_LABEL_FORMAT
:
1773 if (lp
->referenced
== ST_LABEL_TARGET
)
1774 gfc_error ("Label %d at %C already referenced as branch target",
1777 lp
->defined
= ST_LABEL_FORMAT
;
1781 case ST_LABEL_TARGET
:
1782 if (lp
->referenced
== ST_LABEL_FORMAT
)
1783 gfc_error ("Label %d at %C already referenced as a format label",
1786 lp
->defined
= ST_LABEL_TARGET
;
1791 lp
->defined
= ST_LABEL_BAD_TARGET
;
1792 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1798 /* Reference a label. Given a label and its type, see if that
1799 reference is consistent with what is known about that label,
1800 updating the unknown state. Returns FAILURE if something goes
1804 gfc_reference_st_label (gfc_st_label
* lp
, gfc_sl_type type
)
1806 gfc_sl_type label_type
;
1813 labelno
= lp
->value
;
1815 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1816 label_type
= lp
->defined
;
1819 label_type
= lp
->referenced
;
1820 lp
->where
= gfc_current_locus
;
1823 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1825 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1830 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1831 && type
== ST_LABEL_FORMAT
)
1833 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1838 lp
->referenced
= type
;
1846 /************** Symbol table management subroutines ****************/
1848 /* Basic details: Fortran 95 requires a potentially unlimited number
1849 of distinct namespaces when compiling a program unit. This case
1850 occurs during a compilation of internal subprograms because all of
1851 the internal subprograms must be read before we can start
1852 generating code for the host.
1854 Given the tricky nature of the Fortran grammar, we must be able to
1855 undo changes made to a symbol table if the current interpretation
1856 of a statement is found to be incorrect. Whenever a symbol is
1857 looked up, we make a copy of it and link to it. All of these
1858 symbols are kept in a singly linked list so that we can commit or
1859 undo the changes at a later time.
1861 A symtree may point to a symbol node outside of its namespace. In
1862 this case, that symbol has been used as a host associated variable
1863 at some previous time. */
1865 /* Allocate a new namespace structure. Copies the implicit types from
1866 PARENT if PARENT_TYPES is set. */
1869 gfc_get_namespace (gfc_namespace
* parent
, int parent_types
)
1873 gfc_intrinsic_op in
;
1876 ns
= gfc_getmem (sizeof (gfc_namespace
));
1877 ns
->sym_root
= NULL
;
1878 ns
->uop_root
= NULL
;
1879 ns
->default_access
= ACCESS_UNKNOWN
;
1880 ns
->parent
= parent
;
1882 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1883 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1885 /* Initialize default implicit types. */
1886 for (i
= 'a'; i
<= 'z'; i
++)
1888 ns
->set_flag
[i
- 'a'] = 0;
1889 ts
= &ns
->default_type
[i
- 'a'];
1891 if (parent_types
&& ns
->parent
!= NULL
)
1893 /* Copy parent settings */
1894 *ts
= ns
->parent
->default_type
[i
- 'a'];
1898 if (gfc_option
.flag_implicit_none
!= 0)
1904 if ('i' <= i
&& i
<= 'n')
1906 ts
->type
= BT_INTEGER
;
1907 ts
->kind
= gfc_default_integer_kind
;
1912 ts
->kind
= gfc_default_real_kind
;
1922 /* Comparison function for symtree nodes. */
1925 compare_symtree (void * _st1
, void * _st2
)
1927 gfc_symtree
*st1
, *st2
;
1929 st1
= (gfc_symtree
*) _st1
;
1930 st2
= (gfc_symtree
*) _st2
;
1932 return strcmp (st1
->name
, st2
->name
);
1936 /* Allocate a new symtree node and associate it with the new symbol. */
1939 gfc_new_symtree (gfc_symtree
** root
, const char *name
)
1943 st
= gfc_getmem (sizeof (gfc_symtree
));
1944 st
->name
= gfc_get_string (name
);
1946 gfc_insert_bbt (root
, st
, compare_symtree
);
1951 /* Delete a symbol from the tree. Does not free the symbol itself! */
1954 delete_symtree (gfc_symtree
** root
, const char *name
)
1956 gfc_symtree st
, *st0
;
1958 st0
= gfc_find_symtree (*root
, name
);
1960 st
.name
= gfc_get_string (name
);
1961 gfc_delete_bbt (root
, &st
, compare_symtree
);
1967 /* Given a root symtree node and a name, try to find the symbol within
1968 the namespace. Returns NULL if the symbol is not found. */
1971 gfc_find_symtree (gfc_symtree
* st
, const char *name
)
1977 c
= strcmp (name
, st
->name
);
1981 st
= (c
< 0) ? st
->left
: st
->right
;
1988 /* Given a name find a user operator node, creating it if it doesn't
1989 exist. These are much simpler than symbols because they can't be
1990 ambiguous with one another. */
1993 gfc_get_uop (const char *name
)
1998 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2002 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2004 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2005 uop
->name
= gfc_get_string (name
);
2006 uop
->access
= ACCESS_UNKNOWN
;
2007 uop
->ns
= gfc_current_ns
;
2013 /* Given a name find the user operator node. Returns NULL if it does
2017 gfc_find_uop (const char *name
, gfc_namespace
* ns
)
2022 ns
= gfc_current_ns
;
2024 st
= gfc_find_symtree (ns
->uop_root
, name
);
2025 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2029 /* Remove a gfc_symbol structure and everything it points to. */
2032 gfc_free_symbol (gfc_symbol
* sym
)
2038 gfc_free_array_spec (sym
->as
);
2040 free_components (sym
->components
);
2042 gfc_free_expr (sym
->value
);
2044 gfc_free_namelist (sym
->namelist
);
2046 gfc_free_namespace (sym
->formal_ns
);
2048 gfc_free_interface (sym
->generic
);
2050 gfc_free_formal_arglist (sym
->formal
);
2056 /* Allocate and initialize a new symbol node. */
2059 gfc_new_symbol (const char *name
, gfc_namespace
* ns
)
2063 p
= gfc_getmem (sizeof (gfc_symbol
));
2065 gfc_clear_ts (&p
->ts
);
2066 gfc_clear_attr (&p
->attr
);
2069 p
->declared_at
= gfc_current_locus
;
2071 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2072 gfc_internal_error ("new_symbol(): Symbol name too long");
2074 p
->name
= gfc_get_string (name
);
2079 /* Generate an error if a symbol is ambiguous. */
2082 ambiguous_symbol (const char *name
, gfc_symtree
* st
)
2085 if (st
->n
.sym
->module
)
2086 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2087 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2089 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2090 "from current program unit", name
, st
->n
.sym
->name
);
2094 /* Search for a symtree starting in the current namespace, resorting to
2095 any parent namespaces if requested by a nonzero parent_flag.
2096 Returns nonzero if the name is ambiguous. */
2099 gfc_find_sym_tree (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2100 gfc_symtree
** result
)
2105 ns
= gfc_current_ns
;
2109 st
= gfc_find_symtree (ns
->sym_root
, name
);
2115 ambiguous_symbol (name
, st
);
2134 /* Same, but returns the symbol instead. */
2137 gfc_find_symbol (const char *name
, gfc_namespace
* ns
, int parent_flag
,
2138 gfc_symbol
** result
)
2143 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2148 *result
= st
->n
.sym
;
2154 /* Save symbol with the information necessary to back it out. */
2157 save_symbol_data (gfc_symbol
* sym
)
2160 if (sym
->new || sym
->old_symbol
!= NULL
)
2163 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2164 *(sym
->old_symbol
) = *sym
;
2166 sym
->tlink
= changed_syms
;
2171 /* Given a name, find a symbol, or create it if it does not exist yet
2172 in the current namespace. If the symbol is found we make sure that
2175 The integer return code indicates
2177 1 The symbol name was ambiguous
2178 2 The name meant to be established was already host associated.
2180 So if the return value is nonzero, then an error was issued. */
2183 gfc_get_sym_tree (const char *name
, gfc_namespace
* ns
, gfc_symtree
** result
)
2188 /* This doesn't usually happen during resolution. */
2190 ns
= gfc_current_ns
;
2192 /* Try to find the symbol in ns. */
2193 st
= gfc_find_symtree (ns
->sym_root
, name
);
2197 /* If not there, create a new symbol. */
2198 p
= gfc_new_symbol (name
, ns
);
2200 /* Add to the list of tentative symbols. */
2201 p
->old_symbol
= NULL
;
2202 p
->tlink
= changed_syms
;
2207 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2214 /* Make sure the existing symbol is OK. */
2217 ambiguous_symbol (name
, st
);
2223 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2225 /* Symbol is from another namespace. */
2226 gfc_error ("Symbol '%s' at %C has already been host associated",
2233 /* Copy in case this symbol is changed. */
2234 save_symbol_data (p
);
2243 gfc_get_symbol (const char *name
, gfc_namespace
* ns
, gfc_symbol
** result
)
2249 i
= gfc_get_sym_tree (name
, ns
, &st
);
2254 *result
= st
->n
.sym
;
2261 /* Subroutine that searches for a symbol, creating it if it doesn't
2262 exist, but tries to host-associate the symbol if possible. */
2265 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
** result
)
2270 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2273 save_symbol_data (st
->n
.sym
);
2279 if (gfc_current_ns
->parent
!= NULL
)
2281 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2292 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2297 gfc_get_ha_symbol (const char *name
, gfc_symbol
** result
)
2302 i
= gfc_get_ha_sym_tree (name
, &st
);
2305 *result
= st
->n
.sym
;
2312 /* Return true if both symbols could refer to the same data object. Does
2313 not take account of aliasing due to equivalence statements. */
2316 gfc_symbols_could_alias (gfc_symbol
* lsym
, gfc_symbol
* rsym
)
2318 /* Aliasing isn't possible if the symbols have different base types. */
2319 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2322 /* Pointers can point to other pointers, target objects and allocatable
2323 objects. Two allocatable objects cannot share the same storage. */
2324 if (lsym
->attr
.pointer
2325 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2327 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2329 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2336 /* Undoes all the changes made to symbols in the current statement.
2337 This subroutine is made simpler due to the fact that attributes are
2338 never removed once added. */
2341 gfc_undo_symbols (void)
2343 gfc_symbol
*p
, *q
, *old
;
2345 for (p
= changed_syms
; p
; p
= q
)
2351 /* Symbol was new. */
2352 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2356 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2358 gfc_free_symbol (p
);
2362 /* Restore previous state of symbol. Just copy simple stuff. */
2364 old
= p
->old_symbol
;
2366 p
->ts
.type
= old
->ts
.type
;
2367 p
->ts
.kind
= old
->ts
.kind
;
2369 p
->attr
= old
->attr
;
2371 if (p
->value
!= old
->value
)
2373 gfc_free_expr (old
->value
);
2377 if (p
->as
!= old
->as
)
2380 gfc_free_array_spec (p
->as
);
2384 p
->generic
= old
->generic
;
2385 p
->component_access
= old
->component_access
;
2387 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2389 gfc_free_namelist (p
->namelist
);
2395 if (p
->namelist_tail
!= old
->namelist_tail
)
2397 gfc_free_namelist (old
->namelist_tail
);
2398 old
->namelist_tail
->next
= NULL
;
2402 p
->namelist_tail
= old
->namelist_tail
;
2404 if (p
->formal
!= old
->formal
)
2406 gfc_free_formal_arglist (p
->formal
);
2407 p
->formal
= old
->formal
;
2410 gfc_free (p
->old_symbol
);
2411 p
->old_symbol
= NULL
;
2415 changed_syms
= NULL
;
2419 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2420 components of old_symbol that might need deallocation are the "allocatables"
2421 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2422 namelist_tail. In case these differ between old_symbol and sym, it's just
2423 because sym->namelist has gotten a few more items. */
2426 free_old_symbol (gfc_symbol
* sym
)
2428 if (sym
->old_symbol
== NULL
)
2431 if (sym
->old_symbol
->as
!= sym
->as
)
2432 gfc_free_array_spec (sym
->old_symbol
->as
);
2434 if (sym
->old_symbol
->value
!= sym
->value
)
2435 gfc_free_expr (sym
->old_symbol
->value
);
2437 if (sym
->old_symbol
->formal
!= sym
->formal
)
2438 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2440 gfc_free (sym
->old_symbol
);
2441 sym
->old_symbol
= NULL
;
2445 /* Makes the changes made in the current statement permanent-- gets
2446 rid of undo information. */
2449 gfc_commit_symbols (void)
2453 for (p
= changed_syms
; p
; p
= q
)
2460 free_old_symbol (p
);
2462 changed_syms
= NULL
;
2466 /* Makes the changes made in one symbol permanent -- gets rid of undo
2470 gfc_commit_symbol (gfc_symbol
* sym
)
2474 if (changed_syms
== sym
)
2475 changed_syms
= sym
->tlink
;
2478 for (p
= changed_syms
; p
; p
= p
->tlink
)
2479 if (p
->tlink
== sym
)
2481 p
->tlink
= sym
->tlink
;
2490 free_old_symbol (sym
);
2494 /* Recursive function that deletes an entire tree and all the common
2495 head structures it points to. */
2498 free_common_tree (gfc_symtree
* common_tree
)
2500 if (common_tree
== NULL
)
2503 free_common_tree (common_tree
->left
);
2504 free_common_tree (common_tree
->right
);
2506 gfc_free (common_tree
);
2510 /* Recursive function that deletes an entire tree and all the user
2511 operator nodes that it contains. */
2514 free_uop_tree (gfc_symtree
* uop_tree
)
2517 if (uop_tree
== NULL
)
2520 free_uop_tree (uop_tree
->left
);
2521 free_uop_tree (uop_tree
->right
);
2523 gfc_free_interface (uop_tree
->n
.uop
->operator);
2525 gfc_free (uop_tree
->n
.uop
);
2526 gfc_free (uop_tree
);
2530 /* Recursive function that deletes an entire tree and all the symbols
2531 that it contains. */
2534 free_sym_tree (gfc_symtree
* sym_tree
)
2539 if (sym_tree
== NULL
)
2542 free_sym_tree (sym_tree
->left
);
2543 free_sym_tree (sym_tree
->right
);
2545 sym
= sym_tree
->n
.sym
;
2549 gfc_internal_error ("free_sym_tree(): Negative refs");
2551 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2553 /* As formal_ns contains a reference to sym, delete formal_ns just
2554 before the deletion of sym. */
2555 ns
= sym
->formal_ns
;
2556 sym
->formal_ns
= NULL
;
2557 gfc_free_namespace (ns
);
2559 else if (sym
->refs
== 0)
2561 /* Go ahead and delete the symbol. */
2562 gfc_free_symbol (sym
);
2565 gfc_free (sym_tree
);
2569 /* Free the gfc_equiv_info's. */
2572 gfc_free_equiv_infos (gfc_equiv_info
* s
)
2576 gfc_free_equiv_infos (s
->next
);
2581 /* Free the gfc_equiv_lists. */
2584 gfc_free_equiv_lists (gfc_equiv_list
* l
)
2588 gfc_free_equiv_lists (l
->next
);
2589 gfc_free_equiv_infos (l
->equiv
);
2594 /* Free a namespace structure and everything below it. Interface
2595 lists associated with intrinsic operators are not freed. These are
2596 taken care of when a specific name is freed. */
2599 gfc_free_namespace (gfc_namespace
* ns
)
2601 gfc_charlen
*cl
, *cl2
;
2602 gfc_namespace
*p
, *q
;
2611 gcc_assert (ns
->refs
== 0);
2613 gfc_free_statements (ns
->code
);
2615 free_sym_tree (ns
->sym_root
);
2616 free_uop_tree (ns
->uop_root
);
2617 free_common_tree (ns
->common_root
);
2619 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2622 gfc_free_expr (cl
->length
);
2626 free_st_labels (ns
->st_labels
);
2628 gfc_free_equiv (ns
->equiv
);
2629 gfc_free_equiv_lists (ns
->equiv_lists
);
2631 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2632 gfc_free_interface (ns
->operator[i
]);
2634 gfc_free_data (ns
->data
);
2638 /* Recursively free any contained namespaces. */
2644 gfc_free_namespace (q
);
2650 gfc_symbol_init_2 (void)
2653 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2658 gfc_symbol_done_2 (void)
2661 gfc_free_namespace (gfc_current_ns
);
2662 gfc_current_ns
= NULL
;
2666 /* Clear mark bits from symbol nodes associated with a symtree node. */
2669 clear_sym_mark (gfc_symtree
* st
)
2672 st
->n
.sym
->mark
= 0;
2676 /* Recursively traverse the symtree nodes. */
2679 gfc_traverse_symtree (gfc_symtree
* st
, void (*func
) (gfc_symtree
*))
2685 gfc_traverse_symtree (st
->left
, func
);
2686 gfc_traverse_symtree (st
->right
, func
);
2691 /* Recursive namespace traversal function. */
2694 traverse_ns (gfc_symtree
* st
, void (*func
) (gfc_symbol
*))
2700 if (st
->n
.sym
->mark
== 0)
2701 (*func
) (st
->n
.sym
);
2702 st
->n
.sym
->mark
= 1;
2704 traverse_ns (st
->left
, func
);
2705 traverse_ns (st
->right
, func
);
2709 /* Call a given function for all symbols in the namespace. We take
2710 care that each gfc_symbol node is called exactly once. */
2713 gfc_traverse_ns (gfc_namespace
* ns
, void (*func
) (gfc_symbol
*))
2716 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2718 traverse_ns (ns
->sym_root
, func
);
2722 /* Return TRUE if the symbol is an automatic variable. */
2724 gfc_is_var_automatic (gfc_symbol
* sym
)
2726 /* Pointer and allocatable variables are never automatic. */
2727 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2729 /* Check for arrays with non-constant size. */
2730 if (sym
->attr
.dimension
&& sym
->as
2731 && !gfc_is_compile_time_shape (sym
->as
))
2733 /* Check for non-constant length character variables. */
2734 if (sym
->ts
.type
== BT_CHARACTER
2736 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2741 /* Given a symbol, mark it as SAVEd if it is allowed. */
2744 save_symbol (gfc_symbol
* sym
)
2747 if (sym
->attr
.use_assoc
)
2750 if (sym
->attr
.in_common
2752 || sym
->attr
.flavor
!= FL_VARIABLE
)
2754 /* Automatic objects are not saved. */
2755 if (gfc_is_var_automatic (sym
))
2757 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2761 /* Mark those symbols which can be SAVEd as such. */
2764 gfc_save_all (gfc_namespace
* ns
)
2767 gfc_traverse_ns (ns
, save_symbol
);
2772 /* Make sure that no changes to symbols are pending. */
2775 gfc_symbol_state(void) {
2777 if (changed_syms
!= NULL
)
2778 gfc_internal_error("Symbol changes still pending!");
2783 /************** Global symbol handling ************/
2786 /* Search a tree for the global symbol. */
2789 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2795 if (strcmp (symbol
->name
, name
) == 0)
2798 s
= gfc_find_gsymbol (symbol
->left
, name
);
2802 s
= gfc_find_gsymbol (symbol
->right
, name
);
2810 /* Compare two global symbols. Used for managing the BB tree. */
2813 gsym_compare (void * _s1
, void * _s2
)
2815 gfc_gsymbol
*s1
, *s2
;
2817 s1
= (gfc_gsymbol
*)_s1
;
2818 s2
= (gfc_gsymbol
*)_s2
;
2819 return strcmp(s1
->name
, s2
->name
);
2823 /* Get a global symbol, creating it if it doesn't exist. */
2826 gfc_get_gsymbol (const char *name
)
2830 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2834 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2835 s
->type
= GSYM_UNKNOWN
;
2836 s
->name
= gfc_get_string (name
);
2838 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);