1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors
[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
39 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
40 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
41 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
45 const mstring procedures
[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
48 minit ("MODULE-PROC", PROC_MODULE
),
49 minit ("INTERNAL-PROC", PROC_INTERNAL
),
50 minit ("DUMMY-PROC", PROC_DUMMY
),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
57 const mstring intents
[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
60 minit ("IN", INTENT_IN
),
61 minit ("OUT", INTENT_OUT
),
62 minit ("INOUT", INTENT_INOUT
),
66 const mstring access_types
[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
69 minit ("PUBLIC", ACCESS_PUBLIC
),
70 minit ("PRIVATE", ACCESS_PRIVATE
),
74 const mstring ifsrc_types
[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN
),
77 minit ("DECL", IFSRC_DECL
),
78 minit ("BODY", IFSRC_IFBODY
),
79 minit ("USAGE", IFSRC_USAGE
)
82 const mstring save_status
[] =
84 minit ("UNKNOWN", SAVE_NONE
),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order
= 1;
95 gfc_namespace
*gfc_current_ns
;
97 gfc_gsymbol
*gfc_gsym_root
= NULL
;
99 static gfc_symbol
*changed_syms
= NULL
;
101 gfc_dt_list
*gfc_derived_types
;
104 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
106 /* The following static variable indicates whether a particular element has
107 been explicitly set or not. */
109 static int new_flag
[GFC_LETTERS
];
112 /* Handle a correctly parsed IMPLICIT NONE. */
115 gfc_set_implicit_none (void)
119 if (gfc_current_ns
->seen_implicit_none
)
121 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
125 gfc_current_ns
->seen_implicit_none
= 1;
127 for (i
= 0; i
< GFC_LETTERS
; i
++)
129 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
130 gfc_current_ns
->set_flag
[i
] = 1;
135 /* Reset the implicit range flags. */
138 gfc_clear_new_implicit (void)
142 for (i
= 0; i
< GFC_LETTERS
; i
++)
147 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
150 gfc_add_new_implicit_range (int c1
, int c2
)
157 for (i
= c1
; i
<= c2
; i
++)
161 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
173 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
174 the new implicit types back into the existing types will work. */
177 gfc_merge_new_implicit (gfc_typespec
*ts
)
181 if (gfc_current_ns
->seen_implicit_none
)
183 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
187 for (i
= 0; i
< GFC_LETTERS
; i
++)
191 if (gfc_current_ns
->set_flag
[i
])
193 gfc_error ("Letter %c already has an IMPLICIT type at %C",
198 gfc_current_ns
->default_type
[i
] = *ts
;
199 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
200 gfc_current_ns
->set_flag
[i
] = 1;
207 /* Given a symbol, return a pointer to the typespec for its default type. */
210 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
214 letter
= sym
->name
[0];
216 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
217 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
218 "gfortran developers, and should not be used for "
219 "implicitly typed variables");
221 if (letter
< 'a' || letter
> 'z')
222 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym
->name
);
227 return &ns
->default_type
[letter
- 'a'];
231 /* Given a pointer to a symbol, set its type according to the first
232 letter of its name. Fails if the letter in question has no default
236 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
240 if (sym
->ts
.type
!= BT_UNKNOWN
)
241 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
243 ts
= gfc_get_default_type (sym
, ns
);
245 if (ts
->type
== BT_UNKNOWN
)
247 if (error_flag
&& !sym
->attr
.untyped
)
249 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
250 sym
->name
, &sym
->declared_at
);
251 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
258 sym
->attr
.implicit_type
= 1;
262 sym
->ts
.cl
= gfc_get_charlen ();
263 *sym
->ts
.cl
= *ts
->cl
;
266 if (sym
->attr
.is_bind_c
== 1)
268 /* BIND(C) variables should not be implicitly declared. */
269 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
270 "not be C interoperable", sym
->name
, &sym
->declared_at
);
271 sym
->ts
.f90_type
= sym
->ts
.type
;
274 if (sym
->attr
.dummy
!= 0)
276 if (sym
->ns
->proc_name
!= NULL
277 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
278 || sym
->ns
->proc_name
->attr
.function
!= 0)
279 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
281 /* Dummy args to a BIND(C) routine may not be interoperable if
282 they are implicitly typed. */
283 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
284 "be C interoperable but it is a dummy argument to "
285 "the BIND(C) procedure '%s' at %L", sym
->name
,
286 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
287 &(sym
->ns
->proc_name
->declared_at
));
288 sym
->ts
.f90_type
= sym
->ts
.type
;
296 /* This function is called from parse.c(parse_progunit) to check the
297 type of the function is not implicitly typed in the host namespace
298 and to implicitly type the function result, if necessary. */
301 gfc_check_function_type (gfc_namespace
*ns
)
303 gfc_symbol
*proc
= ns
->proc_name
;
305 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
308 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
310 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
313 if (proc
->result
!= proc
)
315 proc
->ts
= proc
->result
->ts
;
316 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
317 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
318 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
319 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
324 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
325 proc
->result
->name
, &proc
->result
->declared_at
);
326 proc
->result
->attr
.untyped
= 1;
332 /******************** Symbol attribute stuff *********************/
334 /* This is a generic conflict-checker. We do this to avoid having a
335 single conflict in two places. */
337 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
338 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
339 #define conf_std(a, b, std) if (attr->a && attr->b)\
348 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
350 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
351 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
352 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
353 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
354 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
355 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
356 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
357 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
358 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
359 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
360 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
361 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
362 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
363 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE";
364 static const char *threadprivate
= "THREADPRIVATE";
370 where
= &gfc_current_locus
;
372 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
376 standard
= GFC_STD_F2003
;
380 /* Check for attributes not allowed in a BLOCK DATA. */
381 if (gfc_current_state () == COMP_BLOCK_DATA
)
385 if (attr
->in_namelist
)
387 if (attr
->allocatable
)
393 if (attr
->access
== ACCESS_PRIVATE
)
395 if (attr
->access
== ACCESS_PUBLIC
)
397 if (attr
->intent
!= INTENT_UNKNOWN
)
403 ("%s attribute not allowed in BLOCK DATA program unit at %L",
409 if (attr
->save
== SAVE_EXPLICIT
)
412 conf (in_common
, save
);
415 switch (attr
->flavor
)
423 a1
= gfc_code2string (flavors
, attr
->flavor
);
428 /* Conflicts between SAVE and PROCEDURE will be checked at
429 resolution stage, see "resolve_fl_procedure". */
438 conf (dummy
, intrinsic
);
439 conf (dummy
, threadprivate
);
440 conf (pointer
, target
);
441 conf (pointer
, intrinsic
);
442 conf (pointer
, elemental
);
443 conf (allocatable
, elemental
);
445 conf (target
, external
);
446 conf (target
, intrinsic
);
448 if (!attr
->if_source
)
449 conf (external
, dimension
); /* See Fortran 95's R504. */
451 conf (external
, intrinsic
);
452 conf (entry
, intrinsic
);
454 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
456 conf (external
, subroutine
);
457 conf (external
, function
);
460 conf (allocatable
, pointer
);
461 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
462 conf_std (allocatable
, function
, GFC_STD_F2003
);
463 conf_std (allocatable
, result
, GFC_STD_F2003
);
464 conf (elemental
, recursive
);
466 conf (in_common
, dummy
);
467 conf (in_common
, allocatable
);
468 conf (in_common
, result
);
470 conf (dummy
, result
);
472 conf (in_equivalence
, use_assoc
);
473 conf (in_equivalence
, dummy
);
474 conf (in_equivalence
, target
);
475 conf (in_equivalence
, pointer
);
476 conf (in_equivalence
, function
);
477 conf (in_equivalence
, result
);
478 conf (in_equivalence
, entry
);
479 conf (in_equivalence
, allocatable
);
480 conf (in_equivalence
, threadprivate
);
482 conf (in_namelist
, pointer
);
483 conf (in_namelist
, allocatable
);
485 conf (entry
, result
);
487 conf (function
, subroutine
);
489 if (!function
&& !subroutine
)
490 conf (is_bind_c
, dummy
);
492 conf (is_bind_c
, cray_pointer
);
493 conf (is_bind_c
, cray_pointee
);
494 conf (is_bind_c
, allocatable
);
495 conf (is_bind_c
, elemental
);
497 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
498 Parameter conflict caught below. Also, value cannot be specified
499 for a dummy procedure. */
501 /* Cray pointer/pointee conflicts. */
502 conf (cray_pointer
, cray_pointee
);
503 conf (cray_pointer
, dimension
);
504 conf (cray_pointer
, pointer
);
505 conf (cray_pointer
, target
);
506 conf (cray_pointer
, allocatable
);
507 conf (cray_pointer
, external
);
508 conf (cray_pointer
, intrinsic
);
509 conf (cray_pointer
, in_namelist
);
510 conf (cray_pointer
, function
);
511 conf (cray_pointer
, subroutine
);
512 conf (cray_pointer
, entry
);
514 conf (cray_pointee
, allocatable
);
515 conf (cray_pointee
, intent
);
516 conf (cray_pointee
, optional
);
517 conf (cray_pointee
, dummy
);
518 conf (cray_pointee
, target
);
519 conf (cray_pointee
, intrinsic
);
520 conf (cray_pointee
, pointer
);
521 conf (cray_pointee
, entry
);
522 conf (cray_pointee
, in_common
);
523 conf (cray_pointee
, in_equivalence
);
524 conf (cray_pointee
, threadprivate
);
527 conf (data
, function
);
529 conf (data
, allocatable
);
530 conf (data
, use_assoc
);
532 conf (value
, pointer
)
533 conf (value
, allocatable
)
534 conf (value
, subroutine
)
535 conf (value
, function
)
536 conf (value
, volatile_
)
537 conf (value
, dimension
)
538 conf (value
, external
)
541 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
544 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
548 conf (is_protected
, intrinsic
)
549 conf (is_protected
, external
)
550 conf (is_protected
, in_common
)
552 conf (volatile_
, intrinsic
)
553 conf (volatile_
, external
)
555 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
562 conf (procedure
, allocatable
)
563 conf (procedure
, dimension
)
564 conf (procedure
, intrinsic
)
565 conf (procedure
, is_protected
)
566 conf (procedure
, target
)
567 conf (procedure
, value
)
568 conf (procedure
, volatile_
)
569 conf (procedure
, entry
)
571 a1
= gfc_code2string (flavors
, attr
->flavor
);
573 if (attr
->in_namelist
574 && attr
->flavor
!= FL_VARIABLE
575 && attr
->flavor
!= FL_PROCEDURE
576 && attr
->flavor
!= FL_UNKNOWN
)
582 switch (attr
->flavor
)
592 conf2 (is_protected
);
602 conf2 (threadprivate
);
604 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
606 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
607 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
614 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
628 /* Conflicts with INTENT will be checked at resolution stage,
629 see "resolve_fl_procedure". */
631 if (attr
->subroutine
)
639 conf2 (threadprivate
);
642 if (!attr
->proc_pointer
)
647 case PROC_ST_FUNCTION
:
657 conf2 (threadprivate
);
677 conf2 (threadprivate
);
680 if (attr
->intent
!= INTENT_UNKNOWN
)
696 conf2 (is_protected
);
702 conf2 (threadprivate
);
716 gfc_error ("%s attribute conflicts with %s attribute at %L",
719 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
720 a1
, a2
, name
, where
);
727 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
728 "with %s attribute at %L", a1
, a2
,
733 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
734 "with %s attribute in '%s' at %L",
735 a1
, a2
, name
, where
);
744 /* Mark a symbol as referenced. */
747 gfc_set_sym_referenced (gfc_symbol
*sym
)
750 if (sym
->attr
.referenced
)
753 sym
->attr
.referenced
= 1;
755 /* Remember which order dummy variables are accessed in. */
757 sym
->dummy_order
= next_dummy_order
++;
761 /* Common subroutine called by attribute changing subroutines in order
762 to prevent them from changing a symbol that has been
763 use-associated. Returns zero if it is OK to change the symbol,
767 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
770 if (attr
->use_assoc
== 0)
774 where
= &gfc_current_locus
;
777 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
780 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
787 /* Generate an error because of a duplicate attribute. */
790 duplicate_attr (const char *attr
, locus
*where
)
794 where
= &gfc_current_locus
;
796 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
800 /* Called from decl.c (attr_decl1) to check attributes, when declared
804 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
807 if (check_used (attr
, NULL
, where
))
810 return check_conflict (attr
, NULL
, where
);
814 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
817 if (check_used (attr
, NULL
, where
))
820 if (attr
->allocatable
)
822 duplicate_attr ("ALLOCATABLE", where
);
826 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
827 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
829 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
834 attr
->allocatable
= 1;
835 return check_conflict (attr
, NULL
, where
);
840 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
843 if (check_used (attr
, name
, where
))
848 duplicate_attr ("DIMENSION", where
);
852 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
853 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
855 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
856 "at %L", name
, where
);
861 return check_conflict (attr
, name
, where
);
866 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
869 if (check_used (attr
, NULL
, where
))
874 duplicate_attr ("EXTERNAL", where
);
878 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
881 attr
->proc_pointer
= 1;
886 return check_conflict (attr
, NULL
, where
);
891 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
894 if (check_used (attr
, NULL
, where
))
899 duplicate_attr ("INTRINSIC", where
);
905 return check_conflict (attr
, NULL
, where
);
910 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
913 if (check_used (attr
, NULL
, where
))
918 duplicate_attr ("OPTIONAL", where
);
923 return check_conflict (attr
, NULL
, where
);
928 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
931 if (check_used (attr
, NULL
, where
))
934 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
935 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
937 duplicate_attr ("POINTER", where
);
941 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
942 || (attr
->if_source
== IFSRC_IFBODY
943 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
944 attr
->proc_pointer
= 1;
948 return check_conflict (attr
, NULL
, where
);
953 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
956 if (check_used (attr
, NULL
, where
))
959 attr
->cray_pointer
= 1;
960 return check_conflict (attr
, NULL
, where
);
965 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
968 if (check_used (attr
, NULL
, where
))
971 if (attr
->cray_pointee
)
973 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
974 " statements", where
);
978 attr
->cray_pointee
= 1;
979 return check_conflict (attr
, NULL
, where
);
984 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
986 if (check_used (attr
, name
, where
))
989 if (attr
->is_protected
)
991 if (gfc_notify_std (GFC_STD_LEGACY
,
992 "Duplicate PROTECTED attribute specified at %L",
998 attr
->is_protected
= 1;
999 return check_conflict (attr
, name
, where
);
1004 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1007 if (check_used (attr
, name
, where
))
1011 return check_conflict (attr
, name
, where
);
1016 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
1019 if (check_used (attr
, name
, where
))
1022 if (gfc_pure (NULL
))
1025 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1030 if (attr
->save
== SAVE_EXPLICIT
)
1032 if (gfc_notify_std (GFC_STD_LEGACY
,
1033 "Duplicate SAVE attribute specified at %L",
1039 attr
->save
= SAVE_EXPLICIT
;
1040 return check_conflict (attr
, name
, where
);
1045 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1048 if (check_used (attr
, name
, where
))
1053 if (gfc_notify_std (GFC_STD_LEGACY
,
1054 "Duplicate VALUE attribute specified at %L",
1061 return check_conflict (attr
, name
, where
);
1066 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1068 /* No check_used needed as 11.2.1 of the F2003 standard allows
1069 that the local identifier made accessible by a use statement can be
1070 given a VOLATILE attribute. */
1072 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1073 if (gfc_notify_std (GFC_STD_LEGACY
,
1074 "Duplicate VOLATILE attribute specified at %L", where
)
1078 attr
->volatile_
= 1;
1079 attr
->volatile_ns
= gfc_current_ns
;
1080 return check_conflict (attr
, name
, where
);
1085 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1088 if (check_used (attr
, name
, where
))
1091 if (attr
->threadprivate
)
1093 duplicate_attr ("THREADPRIVATE", where
);
1097 attr
->threadprivate
= 1;
1098 return check_conflict (attr
, name
, where
);
1103 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1106 if (check_used (attr
, NULL
, where
))
1111 duplicate_attr ("TARGET", where
);
1116 return check_conflict (attr
, NULL
, where
);
1121 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1124 if (check_used (attr
, name
, where
))
1127 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1129 return check_conflict (attr
, name
, where
);
1134 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1137 if (check_used (attr
, name
, where
))
1140 /* Duplicate attribute already checked for. */
1141 attr
->in_common
= 1;
1142 return check_conflict (attr
, name
, where
);
1147 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1150 /* Duplicate attribute already checked for. */
1151 attr
->in_equivalence
= 1;
1152 if (check_conflict (attr
, name
, where
) == FAILURE
)
1155 if (attr
->flavor
== FL_VARIABLE
)
1158 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1163 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1166 if (check_used (attr
, name
, where
))
1170 return check_conflict (attr
, name
, where
);
1175 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1178 attr
->in_namelist
= 1;
1179 return check_conflict (attr
, name
, where
);
1184 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1187 if (check_used (attr
, name
, where
))
1191 return check_conflict (attr
, name
, where
);
1196 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1199 if (check_used (attr
, NULL
, where
))
1202 if (attr
->elemental
)
1204 duplicate_attr ("ELEMENTAL", where
);
1208 attr
->elemental
= 1;
1209 return check_conflict (attr
, NULL
, where
);
1214 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1217 if (check_used (attr
, NULL
, where
))
1222 duplicate_attr ("PURE", where
);
1227 return check_conflict (attr
, NULL
, where
);
1232 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1235 if (check_used (attr
, NULL
, where
))
1238 if (attr
->recursive
)
1240 duplicate_attr ("RECURSIVE", where
);
1244 attr
->recursive
= 1;
1245 return check_conflict (attr
, NULL
, where
);
1250 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1253 if (check_used (attr
, name
, where
))
1258 duplicate_attr ("ENTRY", where
);
1263 return check_conflict (attr
, name
, where
);
1268 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1271 if (attr
->flavor
!= FL_PROCEDURE
1272 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1276 return check_conflict (attr
, name
, where
);
1281 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1284 if (attr
->flavor
!= FL_PROCEDURE
1285 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1288 attr
->subroutine
= 1;
1289 return check_conflict (attr
, name
, where
);
1294 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1297 if (attr
->flavor
!= FL_PROCEDURE
1298 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1302 return check_conflict (attr
, name
, where
);
1307 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1310 if (check_used (attr
, NULL
, where
))
1313 if (attr
->flavor
!= FL_PROCEDURE
1314 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1317 if (attr
->procedure
)
1319 duplicate_attr ("PROCEDURE", where
);
1323 attr
->procedure
= 1;
1325 return check_conflict (attr
, NULL
, where
);
1330 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1334 duplicate_attr ("ABSTRACT", where
);
1343 /* Flavors are special because some flavors are not what Fortran
1344 considers attributes and can be reaffirmed multiple times. */
1347 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1351 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1352 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1353 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1356 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1359 if (attr
->flavor
!= FL_UNKNOWN
)
1362 where
= &gfc_current_locus
;
1365 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1366 gfc_code2string (flavors
, attr
->flavor
), name
,
1367 gfc_code2string (flavors
, f
), where
);
1369 gfc_error ("%s attribute conflicts with %s attribute at %L",
1370 gfc_code2string (flavors
, attr
->flavor
),
1371 gfc_code2string (flavors
, f
), where
);
1378 return check_conflict (attr
, name
, where
);
1383 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1384 const char *name
, locus
*where
)
1387 if (check_used (attr
, name
, where
))
1390 if (attr
->flavor
!= FL_PROCEDURE
1391 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1395 where
= &gfc_current_locus
;
1397 if (attr
->proc
!= PROC_UNKNOWN
)
1399 gfc_error ("%s procedure at %L is already declared as %s procedure",
1400 gfc_code2string (procedures
, t
), where
,
1401 gfc_code2string (procedures
, attr
->proc
));
1408 /* Statement functions are always scalar and functions. */
1409 if (t
== PROC_ST_FUNCTION
1410 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1411 || attr
->dimension
))
1414 return check_conflict (attr
, name
, where
);
1419 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1422 if (check_used (attr
, NULL
, where
))
1425 if (attr
->intent
== INTENT_UNKNOWN
)
1427 attr
->intent
= intent
;
1428 return check_conflict (attr
, NULL
, where
);
1432 where
= &gfc_current_locus
;
1434 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1435 gfc_intent_string (attr
->intent
),
1436 gfc_intent_string (intent
), where
);
1442 /* No checks for use-association in public and private statements. */
1445 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1446 const char *name
, locus
*where
)
1449 if (attr
->access
== ACCESS_UNKNOWN
1450 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1452 attr
->access
= access
;
1453 return check_conflict (attr
, name
, where
);
1457 where
= &gfc_current_locus
;
1458 gfc_error ("ACCESS specification at %L was already specified", where
);
1464 /* Set the is_bind_c field for the given symbol_attribute. */
1467 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1468 int is_proc_lang_bind_spec
)
1471 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1472 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1473 "variables or common blocks", where
);
1474 else if (attr
->is_bind_c
)
1475 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1477 attr
->is_bind_c
= 1;
1480 where
= &gfc_current_locus
;
1482 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1486 return check_conflict (attr
, name
, where
);
1490 /* Set the extension field for the given symbol_attribute. */
1493 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1496 where
= &gfc_current_locus
;
1498 if (attr
->extension
)
1499 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1501 attr
->extension
= 1;
1503 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1512 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1513 gfc_formal_arglist
* formal
, locus
*where
)
1516 if (check_used (&sym
->attr
, sym
->name
, where
))
1520 where
= &gfc_current_locus
;
1522 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1523 && sym
->attr
.if_source
!= IFSRC_DECL
)
1525 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1530 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1532 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1533 "body", sym
->name
, where
);
1537 sym
->formal
= formal
;
1538 sym
->attr
.if_source
= source
;
1544 /* Add a type to a symbol. */
1547 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1552 where
= &gfc_current_locus
;
1554 if (sym
->ts
.type
!= BT_UNKNOWN
)
1556 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1557 if (!(sym
->ts
.type
== ts
->type
1558 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1559 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1562 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1565 if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1566 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1568 if (gfc_option
.warn_surprising
)
1569 gfc_warning (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1572 flavor
= sym
->attr
.flavor
;
1574 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1575 || flavor
== FL_LABEL
1576 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1577 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1579 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1588 /* Clears all attributes. */
1591 gfc_clear_attr (symbol_attribute
*attr
)
1593 memset (attr
, 0, sizeof (symbol_attribute
));
1597 /* Check for missing attributes in the new symbol. Currently does
1598 nothing, but it's not clear that it is unnecessary yet. */
1601 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1602 locus
*where ATTRIBUTE_UNUSED
)
1609 /* Copy an attribute to a symbol attribute, bit by bit. Some
1610 attributes have a lot of side-effects but cannot be present given
1611 where we are called from, so we ignore some bits. */
1614 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1616 int is_proc_lang_bind_spec
;
1618 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1621 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1623 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1625 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1627 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1629 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1631 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1633 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1635 if (src
->threadprivate
1636 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1638 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1640 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1642 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1647 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1650 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1653 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1655 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1657 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1660 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1662 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1664 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1666 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1669 if (src
->flavor
!= FL_UNKNOWN
1670 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1673 if (src
->intent
!= INTENT_UNKNOWN
1674 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1677 if (src
->access
!= ACCESS_UNKNOWN
1678 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1681 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1684 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1686 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1689 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1691 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1695 if (src
->is_c_interop
)
1696 dest
->is_c_interop
= 1;
1700 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1702 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1704 if (src
->proc_pointer
)
1705 dest
->proc_pointer
= 1;
1714 /************** Component name management ************/
1716 /* Component names of a derived type form their own little namespaces
1717 that are separate from all other spaces. The space is composed of
1718 a singly linked list of gfc_component structures whose head is
1719 located in the parent symbol. */
1722 /* Add a component name to a symbol. The call fails if the name is
1723 already present. On success, the component pointer is modified to
1724 point to the additional component structure. */
1727 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1728 gfc_component
**component
)
1730 gfc_component
*p
, *tail
;
1734 for (p
= sym
->components
; p
; p
= p
->next
)
1736 if (strcmp (p
->name
, name
) == 0)
1738 gfc_error ("Component '%s' at %C already declared at %L",
1746 if (sym
->attr
.extension
1747 && gfc_find_component (sym
->components
->ts
.derived
, name
, true, true))
1749 gfc_error ("Component '%s' at %C already in the parent type "
1750 "at %L", name
, &sym
->components
->ts
.derived
->declared_at
);
1754 /* Allocate a new component. */
1755 p
= gfc_get_component ();
1758 sym
->components
= p
;
1762 p
->name
= gfc_get_string (name
);
1763 p
->loc
= gfc_current_locus
;
1770 /* Recursive function to switch derived types of all symbol in a
1774 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1782 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1783 sym
->ts
.derived
= to
;
1785 switch_types (st
->left
, from
, to
);
1786 switch_types (st
->right
, from
, to
);
1790 /* This subroutine is called when a derived type is used in order to
1791 make the final determination about which version to use. The
1792 standard requires that a type be defined before it is 'used', but
1793 such types can appear in IMPLICIT statements before the actual
1794 definition. 'Using' in this context means declaring a variable to
1795 be that type or using the type constructor.
1797 If a type is used and the components haven't been defined, then we
1798 have to have a derived type in a parent unit. We find the node in
1799 the other namespace and point the symtree node in this namespace to
1800 that node. Further reference to this name point to the correct
1801 node. If we can't find the node in a parent namespace, then we have
1804 This subroutine takes a pointer to a symbol node and returns a
1805 pointer to the translated node or NULL for an error. Usually there
1806 is no translation and we return the node we were passed. */
1809 gfc_use_derived (gfc_symbol
*sym
)
1816 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1817 return sym
; /* Already defined. */
1819 if (sym
->ns
->parent
== NULL
)
1822 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1824 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1828 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1831 /* Get rid of symbol sym, translating all references to s. */
1832 for (i
= 0; i
< GFC_LETTERS
; i
++)
1834 t
= &sym
->ns
->default_type
[i
];
1835 if (t
->derived
== sym
)
1839 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1844 /* Unlink from list of modified symbols. */
1845 gfc_commit_symbol (sym
);
1847 switch_types (sym
->ns
->sym_root
, sym
, s
);
1849 /* TODO: Also have to replace sym -> s in other lists like
1850 namelists, common lists and interface lists. */
1851 gfc_free_symbol (sym
);
1856 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1862 /* Given a derived type node and a component name, try to locate the
1863 component structure. Returns the NULL pointer if the component is
1864 not found or the components are private. If noaccess is set, no access
1868 gfc_find_component (gfc_symbol
*sym
, const char *name
,
1869 bool noaccess
, bool silent
)
1876 sym
= gfc_use_derived (sym
);
1881 for (p
= sym
->components
; p
; p
= p
->next
)
1882 if (strcmp (p
->name
, name
) == 0)
1886 && sym
->attr
.extension
1887 && sym
->components
->ts
.type
== BT_DERIVED
)
1889 p
= gfc_find_component (sym
->components
->ts
.derived
, name
,
1891 /* Do not overwrite the error. */
1896 if (p
== NULL
&& !silent
)
1897 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1900 else if (sym
->attr
.use_assoc
&& !noaccess
)
1902 if (p
->attr
.access
== ACCESS_PRIVATE
)
1905 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1910 /* If there were components given and all components are private, error
1911 out at this place. */
1912 if (p
->attr
.access
!= ACCESS_PUBLIC
&& sym
->component_access
== ACCESS_PRIVATE
)
1915 gfc_error ("All components of '%s' are PRIVATE in structure"
1916 " constructor at %C", sym
->name
);
1925 /* Given a symbol, free all of the component structures and everything
1929 free_components (gfc_component
*p
)
1937 gfc_free_array_spec (p
->as
);
1938 gfc_free_expr (p
->initializer
);
1945 /******************** Statement label management ********************/
1947 /* Comparison function for statement labels, used for managing the
1951 compare_st_labels (void *a1
, void *b1
)
1953 int a
= ((gfc_st_label
*) a1
)->value
;
1954 int b
= ((gfc_st_label
*) b1
)->value
;
1960 /* Free a single gfc_st_label structure, making sure the tree is not
1961 messed up. This function is called only when some parse error
1965 gfc_free_st_label (gfc_st_label
*label
)
1971 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1973 if (label
->format
!= NULL
)
1974 gfc_free_expr (label
->format
);
1980 /* Free a whole tree of gfc_st_label structures. */
1983 free_st_labels (gfc_st_label
*label
)
1989 free_st_labels (label
->left
);
1990 free_st_labels (label
->right
);
1992 if (label
->format
!= NULL
)
1993 gfc_free_expr (label
->format
);
1998 /* Given a label number, search for and return a pointer to the label
1999 structure, creating it if it does not exist. */
2002 gfc_get_st_label (int labelno
)
2006 /* First see if the label is already in this namespace. */
2007 lp
= gfc_current_ns
->st_labels
;
2010 if (lp
->value
== labelno
)
2013 if (lp
->value
< labelno
)
2019 lp
= XCNEW (gfc_st_label
);
2021 lp
->value
= labelno
;
2022 lp
->defined
= ST_LABEL_UNKNOWN
;
2023 lp
->referenced
= ST_LABEL_UNKNOWN
;
2025 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
2031 /* Called when a statement with a statement label is about to be
2032 accepted. We add the label to the list of the current namespace,
2033 making sure it hasn't been defined previously and referenced
2037 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2041 labelno
= lp
->value
;
2043 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2044 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2045 &lp
->where
, label_locus
);
2048 lp
->where
= *label_locus
;
2052 case ST_LABEL_FORMAT
:
2053 if (lp
->referenced
== ST_LABEL_TARGET
)
2054 gfc_error ("Label %d at %C already referenced as branch target",
2057 lp
->defined
= ST_LABEL_FORMAT
;
2061 case ST_LABEL_TARGET
:
2062 if (lp
->referenced
== ST_LABEL_FORMAT
)
2063 gfc_error ("Label %d at %C already referenced as a format label",
2066 lp
->defined
= ST_LABEL_TARGET
;
2071 lp
->defined
= ST_LABEL_BAD_TARGET
;
2072 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2078 /* Reference a label. Given a label and its type, see if that
2079 reference is consistent with what is known about that label,
2080 updating the unknown state. Returns FAILURE if something goes
2084 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2086 gfc_sl_type label_type
;
2093 labelno
= lp
->value
;
2095 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2096 label_type
= lp
->defined
;
2099 label_type
= lp
->referenced
;
2100 lp
->where
= gfc_current_locus
;
2103 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2105 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2110 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2111 && type
== ST_LABEL_FORMAT
)
2113 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2118 lp
->referenced
= type
;
2126 /*******A helper function for creating new expressions*************/
2130 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2133 lval
= gfc_get_expr ();
2134 lval
->expr_type
= EXPR_VARIABLE
;
2135 lval
->where
= sym
->declared_at
;
2137 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2139 /* It will always be a full array. */
2140 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2143 lval
->ref
= gfc_get_ref ();
2144 lval
->ref
->type
= REF_ARRAY
;
2145 lval
->ref
->u
.ar
.type
= AR_FULL
;
2146 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2147 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2148 lval
->ref
->u
.ar
.as
= sym
->as
;
2155 /************** Symbol table management subroutines ****************/
2157 /* Basic details: Fortran 95 requires a potentially unlimited number
2158 of distinct namespaces when compiling a program unit. This case
2159 occurs during a compilation of internal subprograms because all of
2160 the internal subprograms must be read before we can start
2161 generating code for the host.
2163 Given the tricky nature of the Fortran grammar, we must be able to
2164 undo changes made to a symbol table if the current interpretation
2165 of a statement is found to be incorrect. Whenever a symbol is
2166 looked up, we make a copy of it and link to it. All of these
2167 symbols are kept in a singly linked list so that we can commit or
2168 undo the changes at a later time.
2170 A symtree may point to a symbol node outside of its namespace. In
2171 this case, that symbol has been used as a host associated variable
2172 at some previous time. */
2174 /* Allocate a new namespace structure. Copies the implicit types from
2175 PARENT if PARENT_TYPES is set. */
2178 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2182 gfc_intrinsic_op in
;
2185 ns
= XCNEW (gfc_namespace
);
2186 ns
->sym_root
= NULL
;
2187 ns
->uop_root
= NULL
;
2188 ns
->finalizers
= NULL
;
2189 ns
->default_access
= ACCESS_UNKNOWN
;
2190 ns
->parent
= parent
;
2192 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2193 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2195 /* Initialize default implicit types. */
2196 for (i
= 'a'; i
<= 'z'; i
++)
2198 ns
->set_flag
[i
- 'a'] = 0;
2199 ts
= &ns
->default_type
[i
- 'a'];
2201 if (parent_types
&& ns
->parent
!= NULL
)
2203 /* Copy parent settings. */
2204 *ts
= ns
->parent
->default_type
[i
- 'a'];
2208 if (gfc_option
.flag_implicit_none
!= 0)
2214 if ('i' <= i
&& i
<= 'n')
2216 ts
->type
= BT_INTEGER
;
2217 ts
->kind
= gfc_default_integer_kind
;
2222 ts
->kind
= gfc_default_real_kind
;
2232 /* Comparison function for symtree nodes. */
2235 compare_symtree (void *_st1
, void *_st2
)
2237 gfc_symtree
*st1
, *st2
;
2239 st1
= (gfc_symtree
*) _st1
;
2240 st2
= (gfc_symtree
*) _st2
;
2242 return strcmp (st1
->name
, st2
->name
);
2246 /* Allocate a new symtree node and associate it with the new symbol. */
2249 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2253 st
= XCNEW (gfc_symtree
);
2254 st
->name
= gfc_get_string (name
);
2255 st
->typebound
= NULL
;
2257 gfc_insert_bbt (root
, st
, compare_symtree
);
2262 /* Delete a symbol from the tree. Does not free the symbol itself! */
2265 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2267 gfc_symtree st
, *st0
;
2269 st0
= gfc_find_symtree (*root
, name
);
2271 st
.name
= gfc_get_string (name
);
2272 gfc_delete_bbt (root
, &st
, compare_symtree
);
2278 /* Given a root symtree node and a name, try to find the symbol within
2279 the namespace. Returns NULL if the symbol is not found. */
2282 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2288 c
= strcmp (name
, st
->name
);
2292 st
= (c
< 0) ? st
->left
: st
->right
;
2299 /* Return a symtree node with a name that is guaranteed to be unique
2300 within the namespace and corresponds to an illegal fortran name. */
2303 gfc_get_unique_symtree (gfc_namespace
*ns
)
2305 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2306 static int serial
= 0;
2308 sprintf (name
, "@%d", serial
++);
2309 return gfc_new_symtree (&ns
->sym_root
, name
);
2313 /* Given a name find a user operator node, creating it if it doesn't
2314 exist. These are much simpler than symbols because they can't be
2315 ambiguous with one another. */
2318 gfc_get_uop (const char *name
)
2323 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2327 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2329 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2330 uop
->name
= gfc_get_string (name
);
2331 uop
->access
= ACCESS_UNKNOWN
;
2332 uop
->ns
= gfc_current_ns
;
2338 /* Given a name find the user operator node. Returns NULL if it does
2342 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2347 ns
= gfc_current_ns
;
2349 st
= gfc_find_symtree (ns
->uop_root
, name
);
2350 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2354 /* Remove a gfc_symbol structure and everything it points to. */
2357 gfc_free_symbol (gfc_symbol
*sym
)
2363 gfc_free_array_spec (sym
->as
);
2365 free_components (sym
->components
);
2367 gfc_free_expr (sym
->value
);
2369 gfc_free_namelist (sym
->namelist
);
2371 gfc_free_namespace (sym
->formal_ns
);
2373 if (!sym
->attr
.generic_copy
)
2374 gfc_free_interface (sym
->generic
);
2376 gfc_free_formal_arglist (sym
->formal
);
2378 gfc_free_namespace (sym
->f2k_derived
);
2384 /* Allocate and initialize a new symbol node. */
2387 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2391 p
= XCNEW (gfc_symbol
);
2393 gfc_clear_ts (&p
->ts
);
2394 gfc_clear_attr (&p
->attr
);
2397 p
->declared_at
= gfc_current_locus
;
2399 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2400 gfc_internal_error ("new_symbol(): Symbol name too long");
2402 p
->name
= gfc_get_string (name
);
2404 /* Make sure flags for symbol being C bound are clear initially. */
2405 p
->attr
.is_bind_c
= 0;
2406 p
->attr
.is_iso_c
= 0;
2407 /* Make sure the binding label field has a Nul char to start. */
2408 p
->binding_label
[0] = '\0';
2410 /* Clear the ptrs we may need. */
2411 p
->common_block
= NULL
;
2412 p
->f2k_derived
= NULL
;
2418 /* Generate an error if a symbol is ambiguous. */
2421 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2424 if (st
->n
.sym
->module
)
2425 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2426 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2428 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2429 "from current program unit", name
, st
->n
.sym
->name
);
2433 /* Search for a symtree starting in the current namespace, resorting to
2434 any parent namespaces if requested by a nonzero parent_flag.
2435 Returns nonzero if the name is ambiguous. */
2438 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2439 gfc_symtree
**result
)
2444 ns
= gfc_current_ns
;
2448 st
= gfc_find_symtree (ns
->sym_root
, name
);
2452 /* Ambiguous generic interfaces are permitted, as long
2453 as the specific interfaces are different. */
2454 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2456 ambiguous_symbol (name
, st
);
2475 /* Same, but returns the symbol instead. */
2478 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2479 gfc_symbol
**result
)
2484 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2489 *result
= st
->n
.sym
;
2495 /* Save symbol with the information necessary to back it out. */
2498 save_symbol_data (gfc_symbol
*sym
)
2501 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2504 sym
->old_symbol
= XCNEW (gfc_symbol
);
2505 *(sym
->old_symbol
) = *sym
;
2507 sym
->tlink
= changed_syms
;
2512 /* Given a name, find a symbol, or create it if it does not exist yet
2513 in the current namespace. If the symbol is found we make sure that
2516 The integer return code indicates
2518 1 The symbol name was ambiguous
2519 2 The name meant to be established was already host associated.
2521 So if the return value is nonzero, then an error was issued. */
2524 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2529 /* This doesn't usually happen during resolution. */
2531 ns
= gfc_current_ns
;
2533 /* Try to find the symbol in ns. */
2534 st
= gfc_find_symtree (ns
->sym_root
, name
);
2538 /* If not there, create a new symbol. */
2539 p
= gfc_new_symbol (name
, ns
);
2541 /* Add to the list of tentative symbols. */
2542 p
->old_symbol
= NULL
;
2543 p
->tlink
= changed_syms
;
2548 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2555 /* Make sure the existing symbol is OK. Ambiguous
2556 generic interfaces are permitted, as long as the
2557 specific interfaces are different. */
2558 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2560 ambiguous_symbol (name
, st
);
2566 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2568 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2569 && (ns
->has_import_set
|| p
->attr
.imported
)))
2571 /* Symbol is from another namespace. */
2572 gfc_error ("Symbol '%s' at %C has already been host associated",
2579 /* Copy in case this symbol is changed. */
2580 save_symbol_data (p
);
2589 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2594 i
= gfc_get_sym_tree (name
, ns
, &st
);
2599 *result
= st
->n
.sym
;
2606 /* Subroutine that searches for a symbol, creating it if it doesn't
2607 exist, but tries to host-associate the symbol if possible. */
2610 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2615 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2618 save_symbol_data (st
->n
.sym
);
2623 if (gfc_current_ns
->parent
!= NULL
)
2625 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2636 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2641 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2646 i
= gfc_get_ha_sym_tree (name
, &st
);
2649 *result
= st
->n
.sym
;
2656 /* Return true if both symbols could refer to the same data object. Does
2657 not take account of aliasing due to equivalence statements. */
2660 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2662 /* Aliasing isn't possible if the symbols have different base types. */
2663 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2666 /* Pointers can point to other pointers, target objects and allocatable
2667 objects. Two allocatable objects cannot share the same storage. */
2668 if (lsym
->attr
.pointer
2669 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2671 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2673 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2680 /* Undoes all the changes made to symbols in the current statement.
2681 This subroutine is made simpler due to the fact that attributes are
2682 never removed once added. */
2685 gfc_undo_symbols (void)
2687 gfc_symbol
*p
, *q
, *old
;
2689 for (p
= changed_syms
; p
; p
= q
)
2695 /* Symbol was new. */
2696 if (p
->attr
.in_common
&& p
->common_block
->head
)
2698 /* If the symbol was added to any common block, it
2699 needs to be removed to stop the resolver looking
2700 for a (possibly) dead symbol. */
2702 if (p
->common_block
->head
== p
)
2703 p
->common_block
->head
= p
->common_next
;
2706 gfc_symbol
*cparent
, *csym
;
2708 cparent
= p
->common_block
->head
;
2709 csym
= cparent
->common_next
;
2714 csym
= csym
->common_next
;
2717 gcc_assert(cparent
->common_next
== p
);
2719 cparent
->common_next
= csym
->common_next
;
2723 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2727 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2729 gfc_free_symbol (p
);
2733 /* Restore previous state of symbol. Just copy simple stuff. */
2735 old
= p
->old_symbol
;
2737 p
->ts
.type
= old
->ts
.type
;
2738 p
->ts
.kind
= old
->ts
.kind
;
2740 p
->attr
= old
->attr
;
2742 if (p
->value
!= old
->value
)
2744 gfc_free_expr (old
->value
);
2748 if (p
->as
!= old
->as
)
2751 gfc_free_array_spec (p
->as
);
2755 p
->generic
= old
->generic
;
2756 p
->component_access
= old
->component_access
;
2758 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2760 gfc_free_namelist (p
->namelist
);
2765 if (p
->namelist_tail
!= old
->namelist_tail
)
2767 gfc_free_namelist (old
->namelist_tail
);
2768 old
->namelist_tail
->next
= NULL
;
2772 p
->namelist_tail
= old
->namelist_tail
;
2774 if (p
->formal
!= old
->formal
)
2776 gfc_free_formal_arglist (p
->formal
);
2777 p
->formal
= old
->formal
;
2780 gfc_free (p
->old_symbol
);
2781 p
->old_symbol
= NULL
;
2785 changed_syms
= NULL
;
2789 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2790 components of old_symbol that might need deallocation are the "allocatables"
2791 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2792 namelist_tail. In case these differ between old_symbol and sym, it's just
2793 because sym->namelist has gotten a few more items. */
2796 free_old_symbol (gfc_symbol
*sym
)
2799 if (sym
->old_symbol
== NULL
)
2802 if (sym
->old_symbol
->as
!= sym
->as
)
2803 gfc_free_array_spec (sym
->old_symbol
->as
);
2805 if (sym
->old_symbol
->value
!= sym
->value
)
2806 gfc_free_expr (sym
->old_symbol
->value
);
2808 if (sym
->old_symbol
->formal
!= sym
->formal
)
2809 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2811 gfc_free (sym
->old_symbol
);
2812 sym
->old_symbol
= NULL
;
2816 /* Makes the changes made in the current statement permanent-- gets
2817 rid of undo information. */
2820 gfc_commit_symbols (void)
2824 for (p
= changed_syms
; p
; p
= q
)
2830 free_old_symbol (p
);
2832 changed_syms
= NULL
;
2836 /* Makes the changes made in one symbol permanent -- gets rid of undo
2840 gfc_commit_symbol (gfc_symbol
*sym
)
2844 if (changed_syms
== sym
)
2845 changed_syms
= sym
->tlink
;
2848 for (p
= changed_syms
; p
; p
= p
->tlink
)
2849 if (p
->tlink
== sym
)
2851 p
->tlink
= sym
->tlink
;
2860 free_old_symbol (sym
);
2864 /* Recursive function that deletes an entire tree and all the common
2865 head structures it points to. */
2868 free_common_tree (gfc_symtree
* common_tree
)
2870 if (common_tree
== NULL
)
2873 free_common_tree (common_tree
->left
);
2874 free_common_tree (common_tree
->right
);
2876 gfc_free (common_tree
);
2880 /* Recursive function that deletes an entire tree and all the user
2881 operator nodes that it contains. */
2884 free_uop_tree (gfc_symtree
*uop_tree
)
2887 if (uop_tree
== NULL
)
2890 free_uop_tree (uop_tree
->left
);
2891 free_uop_tree (uop_tree
->right
);
2893 gfc_free_interface (uop_tree
->n
.uop
->op
);
2895 gfc_free (uop_tree
->n
.uop
);
2896 gfc_free (uop_tree
);
2900 /* Recursive function that deletes an entire tree and all the symbols
2901 that it contains. */
2904 free_sym_tree (gfc_symtree
*sym_tree
)
2909 if (sym_tree
== NULL
)
2912 free_sym_tree (sym_tree
->left
);
2913 free_sym_tree (sym_tree
->right
);
2915 sym
= sym_tree
->n
.sym
;
2919 gfc_internal_error ("free_sym_tree(): Negative refs");
2921 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2923 /* As formal_ns contains a reference to sym, delete formal_ns just
2924 before the deletion of sym. */
2925 ns
= sym
->formal_ns
;
2926 sym
->formal_ns
= NULL
;
2927 gfc_free_namespace (ns
);
2929 else if (sym
->refs
== 0)
2931 /* Go ahead and delete the symbol. */
2932 gfc_free_symbol (sym
);
2935 gfc_free (sym_tree
);
2939 /* Free the derived type list. */
2942 gfc_free_dt_list (void)
2944 gfc_dt_list
*dt
, *n
;
2946 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2952 gfc_derived_types
= NULL
;
2956 /* Free the gfc_equiv_info's. */
2959 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2963 gfc_free_equiv_infos (s
->next
);
2968 /* Free the gfc_equiv_lists. */
2971 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2975 gfc_free_equiv_lists (l
->next
);
2976 gfc_free_equiv_infos (l
->equiv
);
2981 /* Free a finalizer procedure list. */
2984 gfc_free_finalizer (gfc_finalizer
* el
)
2990 --el
->proc_sym
->refs
;
2991 if (!el
->proc_sym
->refs
)
2992 gfc_free_symbol (el
->proc_sym
);
3000 gfc_free_finalizer_list (gfc_finalizer
* list
)
3004 gfc_finalizer
* current
= list
;
3006 gfc_free_finalizer (current
);
3011 /* Free the charlen list from cl to end (end is not freed).
3012 Free the whole list if end is NULL. */
3014 void gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3018 for (; cl
!= end
; cl
= cl2
)
3023 gfc_free_expr (cl
->length
);
3029 /* Free a namespace structure and everything below it. Interface
3030 lists associated with intrinsic operators are not freed. These are
3031 taken care of when a specific name is freed. */
3034 gfc_free_namespace (gfc_namespace
*ns
)
3036 gfc_namespace
*p
, *q
;
3045 gcc_assert (ns
->refs
== 0);
3047 gfc_free_statements (ns
->code
);
3049 free_sym_tree (ns
->sym_root
);
3050 free_uop_tree (ns
->uop_root
);
3051 free_common_tree (ns
->common_root
);
3052 gfc_free_finalizer_list (ns
->finalizers
);
3053 gfc_free_charlen (ns
->cl_list
, NULL
);
3054 free_st_labels (ns
->st_labels
);
3056 gfc_free_equiv (ns
->equiv
);
3057 gfc_free_equiv_lists (ns
->equiv_lists
);
3058 gfc_free_use_stmts (ns
->use_stmts
);
3060 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3061 gfc_free_interface (ns
->op
[i
]);
3063 gfc_free_data (ns
->data
);
3067 /* Recursively free any contained namespaces. */
3072 gfc_free_namespace (q
);
3078 gfc_symbol_init_2 (void)
3081 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3086 gfc_symbol_done_2 (void)
3089 gfc_free_namespace (gfc_current_ns
);
3090 gfc_current_ns
= NULL
;
3091 gfc_free_dt_list ();
3095 /* Clear mark bits from symbol nodes associated with a symtree node. */
3098 clear_sym_mark (gfc_symtree
*st
)
3101 st
->n
.sym
->mark
= 0;
3105 /* Recursively traverse the symtree nodes. */
3108 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
3113 gfc_traverse_symtree (st
->left
, func
);
3115 gfc_traverse_symtree (st
->right
, func
);
3119 /* Recursive namespace traversal function. */
3122 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
3128 traverse_ns (st
->left
, func
);
3130 if (st
->n
.sym
->mark
== 0)
3131 (*func
) (st
->n
.sym
);
3132 st
->n
.sym
->mark
= 1;
3134 traverse_ns (st
->right
, func
);
3138 /* Call a given function for all symbols in the namespace. We take
3139 care that each gfc_symbol node is called exactly once. */
3142 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3145 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3147 traverse_ns (ns
->sym_root
, func
);
3151 /* Return TRUE when name is the name of an intrinsic type. */
3154 gfc_is_intrinsic_typename (const char *name
)
3156 if (strcmp (name
, "integer") == 0
3157 || strcmp (name
, "real") == 0
3158 || strcmp (name
, "character") == 0
3159 || strcmp (name
, "logical") == 0
3160 || strcmp (name
, "complex") == 0
3161 || strcmp (name
, "doubleprecision") == 0
3162 || strcmp (name
, "doublecomplex") == 0)
3169 /* Return TRUE if the symbol is an automatic variable. */
3172 gfc_is_var_automatic (gfc_symbol
*sym
)
3174 /* Pointer and allocatable variables are never automatic. */
3175 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3177 /* Check for arrays with non-constant size. */
3178 if (sym
->attr
.dimension
&& sym
->as
3179 && !gfc_is_compile_time_shape (sym
->as
))
3181 /* Check for non-constant length character variables. */
3182 if (sym
->ts
.type
== BT_CHARACTER
3184 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
3189 /* Given a symbol, mark it as SAVEd if it is allowed. */
3192 save_symbol (gfc_symbol
*sym
)
3195 if (sym
->attr
.use_assoc
)
3198 if (sym
->attr
.in_common
3201 || sym
->attr
.flavor
!= FL_VARIABLE
)
3203 /* Automatic objects are not saved. */
3204 if (gfc_is_var_automatic (sym
))
3206 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3210 /* Mark those symbols which can be SAVEd as such. */
3213 gfc_save_all (gfc_namespace
*ns
)
3215 gfc_traverse_ns (ns
, save_symbol
);
3220 /* Make sure that no changes to symbols are pending. */
3223 gfc_symbol_state(void) {
3225 if (changed_syms
!= NULL
)
3226 gfc_internal_error("Symbol changes still pending!");
3231 /************** Global symbol handling ************/
3234 /* Search a tree for the global symbol. */
3237 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3246 c
= strcmp (name
, symbol
->name
);
3250 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3257 /* Compare two global symbols. Used for managing the BB tree. */
3260 gsym_compare (void *_s1
, void *_s2
)
3262 gfc_gsymbol
*s1
, *s2
;
3264 s1
= (gfc_gsymbol
*) _s1
;
3265 s2
= (gfc_gsymbol
*) _s2
;
3266 return strcmp (s1
->name
, s2
->name
);
3270 /* Get a global symbol, creating it if it doesn't exist. */
3273 gfc_get_gsymbol (const char *name
)
3277 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3281 s
= XCNEW (gfc_gsymbol
);
3282 s
->type
= GSYM_UNKNOWN
;
3283 s
->name
= gfc_get_string (name
);
3285 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3292 get_iso_c_binding_dt (int sym_id
)
3294 gfc_dt_list
*dt_list
;
3296 dt_list
= gfc_derived_types
;
3298 /* Loop through the derived types in the name list, searching for
3299 the desired symbol from iso_c_binding. Search the parent namespaces
3300 if necessary and requested to (parent_flag). */
3301 while (dt_list
!= NULL
)
3303 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3304 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3305 return dt_list
->derived
;
3307 dt_list
= dt_list
->next
;
3314 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3315 with C. This is necessary for any derived type that is BIND(C) and for
3316 derived types that are parameters to functions that are BIND(C). All
3317 fields of the derived type are required to be interoperable, and are tested
3318 for such. If an error occurs, the errors are reported here, allowing for
3319 multiple errors to be handled for a single derived type. */
3322 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3324 gfc_component
*curr_comp
= NULL
;
3325 gfc_try is_c_interop
= FAILURE
;
3326 gfc_try retval
= SUCCESS
;
3328 if (derived_sym
== NULL
)
3329 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3330 "unexpectedly NULL");
3332 /* If we've already looked at this derived symbol, do not look at it again
3333 so we don't repeat warnings/errors. */
3334 if (derived_sym
->ts
.is_c_interop
)
3337 /* The derived type must have the BIND attribute to be interoperable
3338 J3/04-007, Section 15.2.3. */
3339 if (derived_sym
->attr
.is_bind_c
!= 1)
3341 derived_sym
->ts
.is_c_interop
= 0;
3342 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3343 "attribute to be C interoperable", derived_sym
->name
,
3344 &(derived_sym
->declared_at
));
3348 curr_comp
= derived_sym
->components
;
3350 /* TODO: is this really an error? */
3351 if (curr_comp
== NULL
)
3353 gfc_error ("Derived type '%s' at %L is empty",
3354 derived_sym
->name
, &(derived_sym
->declared_at
));
3358 /* Initialize the derived type as being C interoperable.
3359 If we find an error in the components, this will be set false. */
3360 derived_sym
->ts
.is_c_interop
= 1;
3362 /* Loop through the list of components to verify that the kind of
3363 each is a C interoperable type. */
3366 /* The components cannot be pointers (fortran sense).
3367 J3/04-007, Section 15.2.3, C1505. */
3368 if (curr_comp
->attr
.pointer
!= 0)
3370 gfc_error ("Component '%s' at %L cannot have the "
3371 "POINTER attribute because it is a member "
3372 "of the BIND(C) derived type '%s' at %L",
3373 curr_comp
->name
, &(curr_comp
->loc
),
3374 derived_sym
->name
, &(derived_sym
->declared_at
));
3378 /* The components cannot be allocatable.
3379 J3/04-007, Section 15.2.3, C1505. */
3380 if (curr_comp
->attr
.allocatable
!= 0)
3382 gfc_error ("Component '%s' at %L cannot have the "
3383 "ALLOCATABLE attribute because it is a member "
3384 "of the BIND(C) derived type '%s' at %L",
3385 curr_comp
->name
, &(curr_comp
->loc
),
3386 derived_sym
->name
, &(derived_sym
->declared_at
));
3390 /* BIND(C) derived types must have interoperable components. */
3391 if (curr_comp
->ts
.type
== BT_DERIVED
3392 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3393 && curr_comp
->ts
.derived
!= derived_sym
)
3395 /* This should be allowed; the draft says a derived-type can not
3396 have type parameters if it is has the BIND attribute. Type
3397 parameters seem to be for making parameterized derived types.
3398 There's no need to verify the type if it is c_ptr/c_funptr. */
3399 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3403 /* Grab the typespec for the given component and test the kind. */
3404 is_c_interop
= verify_c_interop (&(curr_comp
->ts
));
3406 if (is_c_interop
!= SUCCESS
)
3408 /* Report warning and continue since not fatal. The
3409 draft does specify a constraint that requires all fields
3410 to interoperate, but if the user says real(4), etc., it
3411 may interoperate with *something* in C, but the compiler
3412 most likely won't know exactly what. Further, it may not
3413 interoperate with the same data type(s) in C if the user
3414 recompiles with different flags (e.g., -m32 and -m64 on
3415 x86_64 and using integer(4) to claim interop with a
3417 if (derived_sym
->attr
.is_bind_c
== 1)
3418 /* If the derived type is bind(c), all fields must be
3420 gfc_warning ("Component '%s' in derived type '%s' at %L "
3421 "may not be C interoperable, even though "
3422 "derived type '%s' is BIND(C)",
3423 curr_comp
->name
, derived_sym
->name
,
3424 &(curr_comp
->loc
), derived_sym
->name
);
3426 /* If derived type is param to bind(c) routine, or to one
3427 of the iso_c_binding procs, it must be interoperable, so
3428 all fields must interop too. */
3429 gfc_warning ("Component '%s' in derived type '%s' at %L "
3430 "may not be C interoperable",
3431 curr_comp
->name
, derived_sym
->name
,
3436 curr_comp
= curr_comp
->next
;
3437 } while (curr_comp
!= NULL
);
3440 /* Make sure we don't have conflicts with the attributes. */
3441 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3443 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3444 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3445 &(derived_sym
->declared_at
));
3449 if (derived_sym
->attr
.sequence
!= 0)
3451 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3452 "attribute because it is BIND(C)", derived_sym
->name
,
3453 &(derived_sym
->declared_at
));
3457 /* Mark the derived type as not being C interoperable if we found an
3458 error. If there were only warnings, proceed with the assumption
3459 it's interoperable. */
3460 if (retval
== FAILURE
)
3461 derived_sym
->ts
.is_c_interop
= 0;
3467 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3470 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3471 const char *module_name
)
3473 gfc_symtree
*tmp_symtree
;
3474 gfc_symbol
*tmp_sym
;
3476 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3478 if (tmp_symtree
!= NULL
)
3479 tmp_sym
= tmp_symtree
->n
.sym
;
3483 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3484 "create symbol for %s", ptr_name
);
3487 /* Set up the symbol's important fields. Save attr required so we can
3488 initialize the ptr to NULL. */
3489 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3490 tmp_sym
->ts
.is_c_interop
= 1;
3491 tmp_sym
->attr
.is_c_interop
= 1;
3492 tmp_sym
->ts
.is_iso_c
= 1;
3493 tmp_sym
->ts
.type
= BT_DERIVED
;
3495 /* The c_ptr and c_funptr derived types will provide the
3496 definition for c_null_ptr and c_null_funptr, respectively. */
3497 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3498 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3500 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3501 if (tmp_sym
->ts
.derived
== NULL
)
3503 /* This can occur if the user forgot to declare c_ptr or
3504 c_funptr and they're trying to use one of the procedures
3505 that has arg(s) of the missing type. In this case, a
3506 regular version of the thing should have been put in the
3508 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3509 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3510 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3511 ? "_gfortran_iso_c_binding_c_ptr"
3512 : "_gfortran_iso_c_binding_c_funptr"));
3514 tmp_sym
->ts
.derived
=
3515 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3516 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3519 /* Module name is some mangled version of iso_c_binding. */
3520 tmp_sym
->module
= gfc_get_string (module_name
);
3522 /* Say it's from the iso_c_binding module. */
3523 tmp_sym
->attr
.is_iso_c
= 1;
3525 tmp_sym
->attr
.use_assoc
= 1;
3526 tmp_sym
->attr
.is_bind_c
= 1;
3527 /* Set the binding_label. */
3528 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3530 /* Set the c_address field of c_null_ptr and c_null_funptr to
3531 the value of NULL. */
3532 tmp_sym
->value
= gfc_get_expr ();
3533 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3534 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3535 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3536 /* Create a constructor with no expr, that way we can recognize if the user
3537 tries to call the structure constructor for one of the iso_c_binding
3538 derived types during resolution (resolve_structure_cons). */
3539 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3540 /* Must declare c_null_ptr and c_null_funptr as having the
3541 PARAMETER attribute so they can be used in init expressions. */
3542 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3548 /* Add a formal argument, gfc_formal_arglist, to the
3549 end of the given list of arguments. Set the reference to the
3550 provided symbol, param_sym, in the argument. */
3553 add_formal_arg (gfc_formal_arglist
**head
,
3554 gfc_formal_arglist
**tail
,
3555 gfc_formal_arglist
*formal_arg
,
3556 gfc_symbol
*param_sym
)
3558 /* Put in list, either as first arg or at the tail (curr arg). */
3560 *head
= *tail
= formal_arg
;
3563 (*tail
)->next
= formal_arg
;
3564 (*tail
) = formal_arg
;
3567 (*tail
)->sym
= param_sym
;
3568 (*tail
)->next
= NULL
;
3574 /* Generates a symbol representing the CPTR argument to an
3575 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3576 CPTR and add it to the provided argument list. */
3579 gen_cptr_param (gfc_formal_arglist
**head
,
3580 gfc_formal_arglist
**tail
,
3581 const char *module_name
,
3582 gfc_namespace
*ns
, const char *c_ptr_name
,
3585 gfc_symbol
*param_sym
= NULL
;
3586 gfc_symbol
*c_ptr_sym
= NULL
;
3587 gfc_symtree
*param_symtree
= NULL
;
3588 gfc_formal_arglist
*formal_arg
= NULL
;
3589 const char *c_ptr_in
;
3590 const char *c_ptr_type
= NULL
;
3592 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3593 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3595 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3597 if(c_ptr_name
== NULL
)
3598 c_ptr_in
= "gfc_cptr__";
3600 c_ptr_in
= c_ptr_name
;
3601 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3602 if (param_symtree
!= NULL
)
3603 param_sym
= param_symtree
->n
.sym
;
3605 gfc_internal_error ("gen_cptr_param(): Unable to "
3606 "create symbol for %s", c_ptr_in
);
3608 /* Set up the appropriate fields for the new c_ptr param sym. */
3610 param_sym
->attr
.flavor
= FL_DERIVED
;
3611 param_sym
->ts
.type
= BT_DERIVED
;
3612 param_sym
->attr
.intent
= INTENT_IN
;
3613 param_sym
->attr
.dummy
= 1;
3615 /* This will pass the ptr to the iso_c routines as a (void *). */
3616 param_sym
->attr
.value
= 1;
3617 param_sym
->attr
.use_assoc
= 1;
3619 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3621 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3622 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3624 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3625 if (c_ptr_sym
== NULL
)
3627 /* This can happen if the user did not define c_ptr but they are
3628 trying to use one of the iso_c_binding functions that need it. */
3629 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3630 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3631 (const char *)c_ptr_type
);
3633 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3634 (const char *)c_ptr_type
);
3636 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3639 param_sym
->ts
.derived
= c_ptr_sym
;
3640 param_sym
->module
= gfc_get_string (module_name
);
3642 /* Make new formal arg. */
3643 formal_arg
= gfc_get_formal_arglist ();
3644 /* Add arg to list of formal args (the CPTR arg). */
3645 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3649 /* Generates a symbol representing the FPTR argument to an
3650 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3651 FPTR and add it to the provided argument list. */
3654 gen_fptr_param (gfc_formal_arglist
**head
,
3655 gfc_formal_arglist
**tail
,
3656 const char *module_name
,
3657 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3659 gfc_symbol
*param_sym
= NULL
;
3660 gfc_symtree
*param_symtree
= NULL
;
3661 gfc_formal_arglist
*formal_arg
= NULL
;
3662 const char *f_ptr_out
= "gfc_fptr__";
3664 if (f_ptr_name
!= NULL
)
3665 f_ptr_out
= f_ptr_name
;
3667 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3668 if (param_symtree
!= NULL
)
3669 param_sym
= param_symtree
->n
.sym
;
3671 gfc_internal_error ("generateFPtrParam(): Unable to "
3672 "create symbol for %s", f_ptr_out
);
3674 /* Set up the necessary fields for the fptr output param sym. */
3677 param_sym
->attr
.proc_pointer
= 1;
3679 param_sym
->attr
.pointer
= 1;
3680 param_sym
->attr
.dummy
= 1;
3681 param_sym
->attr
.use_assoc
= 1;
3683 /* ISO C Binding type to allow any pointer type as actual param. */
3684 param_sym
->ts
.type
= BT_VOID
;
3685 param_sym
->module
= gfc_get_string (module_name
);
3688 formal_arg
= gfc_get_formal_arglist ();
3689 /* Add arg to list of formal args. */
3690 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3694 /* Generates a symbol representing the optional SHAPE argument for the
3695 iso_c_binding c_f_pointer() procedure. Also, create a
3696 gfc_formal_arglist for the SHAPE and add it to the provided
3700 gen_shape_param (gfc_formal_arglist
**head
,
3701 gfc_formal_arglist
**tail
,
3702 const char *module_name
,
3703 gfc_namespace
*ns
, const char *shape_param_name
)
3705 gfc_symbol
*param_sym
= NULL
;
3706 gfc_symtree
*param_symtree
= NULL
;
3707 gfc_formal_arglist
*formal_arg
= NULL
;
3708 const char *shape_param
= "gfc_shape_array__";
3711 if (shape_param_name
!= NULL
)
3712 shape_param
= shape_param_name
;
3714 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3715 if (param_symtree
!= NULL
)
3716 param_sym
= param_symtree
->n
.sym
;
3718 gfc_internal_error ("generateShapeParam(): Unable to "
3719 "create symbol for %s", shape_param
);
3721 /* Set up the necessary fields for the shape input param sym. */
3723 param_sym
->attr
.dummy
= 1;
3724 param_sym
->attr
.use_assoc
= 1;
3726 /* Integer array, rank 1, describing the shape of the object. Make it's
3727 type BT_VOID initially so we can accept any type/kind combination of
3728 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3729 of BT_INTEGER type. */
3730 param_sym
->ts
.type
= BT_VOID
;
3732 /* Initialize the kind to default integer. However, it will be overridden
3733 during resolution to match the kind of the SHAPE parameter given as
3734 the actual argument (to allow for any valid integer kind). */
3735 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3736 param_sym
->as
= gfc_get_array_spec ();
3738 /* Clear out the dimension info for the array. */
3739 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3741 param_sym
->as
->lower
[i
] = NULL
;
3742 param_sym
->as
->upper
[i
] = NULL
;
3744 param_sym
->as
->rank
= 1;
3745 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3747 /* The extent is unknown until we get it. The length give us
3748 the rank the incoming pointer. */
3749 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3751 /* The arg is also optional; it is required iff the second arg
3752 (fptr) is to an array, otherwise, it's ignored. */
3753 param_sym
->attr
.optional
= 1;
3754 param_sym
->attr
.intent
= INTENT_IN
;
3755 param_sym
->attr
.dimension
= 1;
3756 param_sym
->module
= gfc_get_string (module_name
);
3759 formal_arg
= gfc_get_formal_arglist ();
3760 /* Add arg to list of formal args. */
3761 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3764 /* Add a procedure interface to the given symbol (i.e., store a
3765 reference to the list of formal arguments). */
3768 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3769 gfc_formal_arglist
*formal
)
3772 sym
->formal
= formal
;
3773 sym
->attr
.if_source
= source
;
3776 /* Copy the formal args from an existing symbol, src, into a new
3777 symbol, dest. New formal args are created, and the description of
3778 each arg is set according to the existing ones. This function is
3779 used when creating procedure declaration variables from a procedure
3780 declaration statement (see match_proc_decl()) to create the formal
3781 args based on the args of a given named interface. */
3784 copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3786 gfc_formal_arglist
*head
= NULL
;
3787 gfc_formal_arglist
*tail
= NULL
;
3788 gfc_formal_arglist
*formal_arg
= NULL
;
3789 gfc_formal_arglist
*curr_arg
= NULL
;
3790 gfc_formal_arglist
*formal_prev
= NULL
;
3791 /* Save current namespace so we can change it for formal args. */
3792 gfc_namespace
*parent_ns
= gfc_current_ns
;
3794 /* Create a new namespace, which will be the formal ns (namespace
3795 of the formal args). */
3796 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3797 gfc_current_ns
->proc_name
= dest
;
3799 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3801 formal_arg
= gfc_get_formal_arglist ();
3802 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3804 /* May need to copy more info for the symbol. */
3805 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3806 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3807 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
3808 copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
3810 /* If this isn't the first arg, set up the next ptr. For the
3811 last arg built, the formal_arg->next will never get set to
3812 anything other than NULL. */
3813 if (formal_prev
!= NULL
)
3814 formal_prev
->next
= formal_arg
;
3816 formal_arg
->next
= NULL
;
3818 formal_prev
= formal_arg
;
3820 /* Add arg to list of formal args. */
3821 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3824 /* Add the interface to the symbol. */
3825 add_proc_interface (dest
, IFSRC_DECL
, head
);
3827 /* Store the formal namespace information. */
3828 if (dest
->formal
!= NULL
)
3829 /* The current ns should be that for the dest proc. */
3830 dest
->formal_ns
= gfc_current_ns
;
3831 /* Restore the current namespace to what it was on entry. */
3832 gfc_current_ns
= parent_ns
;
3835 /* Builds the parameter list for the iso_c_binding procedure
3836 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3837 generic version of either the c_f_pointer or c_f_procpointer
3838 functions. The new_proc_sym represents a "resolved" version of the
3839 symbol. The functions are resolved to match the types of their
3840 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3841 something similar to c_f_pointer_i4 if the type of data object fptr
3842 pointed to was a default integer. The actual name of the resolved
3843 procedure symbol is further mangled with the module name, etc., but
3844 the idea holds true. */
3847 build_formal_args (gfc_symbol
*new_proc_sym
,
3848 gfc_symbol
*old_sym
, int add_optional_arg
)
3850 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3851 gfc_namespace
*parent_ns
= NULL
;
3853 parent_ns
= gfc_current_ns
;
3854 /* Create a new namespace, which will be the formal ns (namespace
3855 of the formal args). */
3856 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3857 gfc_current_ns
->proc_name
= new_proc_sym
;
3859 /* Generate the params. */
3860 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3862 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3863 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3864 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3865 gfc_current_ns
, "fptr", 1);
3867 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3869 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3870 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3871 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3872 gfc_current_ns
, "fptr", 0);
3873 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3874 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
3875 gfc_current_ns
, "shape");
3878 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3880 /* c_associated has one required arg and one optional; both
3882 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3883 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3884 if (add_optional_arg
)
3886 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3887 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3888 /* The last param is optional so mark it as such. */
3889 tail
->sym
->attr
.optional
= 1;
3893 /* Add the interface (store formal args to new_proc_sym). */
3894 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3896 /* Set up the formal_ns pointer to the one created for the
3897 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3898 new_proc_sym
->formal_ns
= gfc_current_ns
;
3900 gfc_current_ns
= parent_ns
;
3904 std_for_isocbinding_symbol (int id
)
3908 #define NAMED_INTCST(a,b,c,d) \
3911 #include "iso-c-binding.def"
3914 return GFC_STD_F2003
;
3918 /* Generate the given set of C interoperable kind objects, or all
3919 interoperable kinds. This function will only be given kind objects
3920 for valid iso_c_binding defined types because this is verified when
3921 the 'use' statement is parsed. If the user gives an 'only' clause,
3922 the specific kinds are looked up; if they don't exist, an error is
3923 reported. If the user does not give an 'only' clause, all
3924 iso_c_binding symbols are generated. If a list of specific kinds
3925 is given, it must have a NULL in the first empty spot to mark the
3930 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3931 const char *local_name
)
3933 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3934 : c_interop_kinds_table
[s
].name
;
3935 gfc_symtree
*tmp_symtree
= NULL
;
3936 gfc_symbol
*tmp_sym
= NULL
;
3937 gfc_dt_list
**dt_list_ptr
= NULL
;
3938 gfc_component
*tmp_comp
= NULL
;
3939 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3942 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
3944 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3946 /* Already exists in this scope so don't re-add it.
3947 TODO: we should probably check that it's really the same symbol. */
3948 if (tmp_symtree
!= NULL
)
3951 /* Create the sym tree in the current ns. */
3952 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3954 tmp_sym
= tmp_symtree
->n
.sym
;
3956 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3959 /* Say what module this symbol belongs to. */
3960 tmp_sym
->module
= gfc_get_string (mod_name
);
3961 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3962 tmp_sym
->intmod_sym_id
= s
;
3967 #define NAMED_INTCST(a,b,c,d) case a :
3968 #define NAMED_REALCST(a,b,c) case a :
3969 #define NAMED_CMPXCST(a,b,c) case a :
3970 #define NAMED_LOGCST(a,b,c) case a :
3971 #define NAMED_CHARKNDCST(a,b,c) case a :
3972 #include "iso-c-binding.def"
3974 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3976 /* Initialize an integer constant expression node. */
3977 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3978 tmp_sym
->ts
.type
= BT_INTEGER
;
3979 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3981 /* Mark this type as a C interoperable one. */
3982 tmp_sym
->ts
.is_c_interop
= 1;
3983 tmp_sym
->ts
.is_iso_c
= 1;
3984 tmp_sym
->value
->ts
.is_c_interop
= 1;
3985 tmp_sym
->value
->ts
.is_iso_c
= 1;
3986 tmp_sym
->attr
.is_c_interop
= 1;
3988 /* Tell what f90 type this c interop kind is valid. */
3989 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3991 /* Say it's from the iso_c_binding module. */
3992 tmp_sym
->attr
.is_iso_c
= 1;
3994 /* Make it use associated. */
3995 tmp_sym
->attr
.use_assoc
= 1;
3999 #define NAMED_CHARCST(a,b,c) case a :
4000 #include "iso-c-binding.def"
4002 /* Initialize an integer constant expression node for the
4003 length of the character. */
4004 tmp_sym
->value
= gfc_get_expr ();
4005 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
4006 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
4007 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
4008 tmp_sym
->value
->where
= gfc_current_locus
;
4009 tmp_sym
->value
->ts
.is_c_interop
= 1;
4010 tmp_sym
->value
->ts
.is_iso_c
= 1;
4011 tmp_sym
->value
->value
.character
.length
= 1;
4012 tmp_sym
->value
->value
.character
.string
= gfc_get_wide_string (2);
4013 tmp_sym
->value
->value
.character
.string
[0]
4014 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4015 tmp_sym
->value
->value
.character
.string
[1] = '\0';
4016 tmp_sym
->ts
.cl
= gfc_get_charlen ();
4017 tmp_sym
->ts
.cl
->length
= gfc_int_expr (1);
4019 /* May not need this in both attr and ts, but do need in
4020 attr for writing module file. */
4021 tmp_sym
->attr
.is_c_interop
= 1;
4023 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4024 tmp_sym
->ts
.type
= BT_CHARACTER
;
4026 /* Need to set it to the C_CHAR kind. */
4027 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4029 /* Mark this type as a C interoperable one. */
4030 tmp_sym
->ts
.is_c_interop
= 1;
4031 tmp_sym
->ts
.is_iso_c
= 1;
4033 /* Tell what f90 type this c interop kind is valid. */
4034 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4036 /* Say it's from the iso_c_binding module. */
4037 tmp_sym
->attr
.is_iso_c
= 1;
4039 /* Make it use associated. */
4040 tmp_sym
->attr
.use_assoc
= 1;
4043 case ISOCBINDING_PTR
:
4044 case ISOCBINDING_FUNPTR
:
4046 /* Initialize an integer constant expression node. */
4047 tmp_sym
->attr
.flavor
= FL_DERIVED
;
4048 tmp_sym
->ts
.is_c_interop
= 1;
4049 tmp_sym
->attr
.is_c_interop
= 1;
4050 tmp_sym
->attr
.is_iso_c
= 1;
4051 tmp_sym
->ts
.is_iso_c
= 1;
4052 tmp_sym
->ts
.type
= BT_DERIVED
;
4054 /* A derived type must have the bind attribute to be
4055 interoperable (J3/04-007, Section 15.2.3), even though
4056 the binding label is not used. */
4057 tmp_sym
->attr
.is_bind_c
= 1;
4059 tmp_sym
->attr
.referenced
= 1;
4061 tmp_sym
->ts
.derived
= tmp_sym
;
4063 /* Add the symbol created for the derived type to the current ns. */
4064 dt_list_ptr
= &(gfc_derived_types
);
4065 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4066 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4068 /* There is already at least one derived type in the list, so append
4069 the one we're currently building for c_ptr or c_funptr. */
4070 if (*dt_list_ptr
!= NULL
)
4071 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4072 (*dt_list_ptr
) = gfc_get_dt_list ();
4073 (*dt_list_ptr
)->derived
= tmp_sym
;
4074 (*dt_list_ptr
)->next
= NULL
;
4076 /* Set up the component of the derived type, which will be
4077 an integer with kind equal to c_ptr_size. Mangle the name of
4078 the field for the c_address to prevent the curious user from
4079 trying to access it from Fortran. */
4080 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
4081 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
4082 if (tmp_comp
== NULL
)
4083 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4084 "create component for c_address");
4086 tmp_comp
->ts
.type
= BT_INTEGER
;
4088 /* Set this because the module will need to read/write this field. */
4089 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4091 /* The kinds for c_ptr and c_funptr are the same. */
4092 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4093 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4095 tmp_comp
->attr
.pointer
= 0;
4096 tmp_comp
->attr
.dimension
= 0;
4098 /* Mark the component as C interoperable. */
4099 tmp_comp
->ts
.is_c_interop
= 1;
4101 /* Make it use associated (iso_c_binding module). */
4102 tmp_sym
->attr
.use_assoc
= 1;
4105 case ISOCBINDING_NULL_PTR
:
4106 case ISOCBINDING_NULL_FUNPTR
:
4107 gen_special_c_interop_ptr (s
, name
, mod_name
);
4110 case ISOCBINDING_F_POINTER
:
4111 case ISOCBINDING_ASSOCIATED
:
4112 case ISOCBINDING_LOC
:
4113 case ISOCBINDING_FUNLOC
:
4114 case ISOCBINDING_F_PROCPOINTER
:
4116 tmp_sym
->attr
.proc
= PROC_MODULE
;
4118 /* Use the procedure's name as it is in the iso_c_binding module for
4119 setting the binding label in case the user renamed the symbol. */
4120 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
4121 c_interop_kinds_table
[s
].name
);
4122 tmp_sym
->attr
.is_iso_c
= 1;
4123 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4124 tmp_sym
->attr
.subroutine
= 1;
4127 /* TODO! This needs to be finished more for the expr of the
4128 function or something!
4129 This may not need to be here, because trying to do c_loc
4131 if (s
== ISOCBINDING_ASSOCIATED
)
4133 tmp_sym
->attr
.function
= 1;
4134 tmp_sym
->ts
.type
= BT_LOGICAL
;
4135 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4136 tmp_sym
->result
= tmp_sym
;
4140 /* Here, we're taking the simple approach. We're defining
4141 c_loc as an external identifier so the compiler will put
4142 what we expect on the stack for the address we want the
4144 tmp_sym
->ts
.type
= BT_DERIVED
;
4145 if (s
== ISOCBINDING_LOC
)
4146 tmp_sym
->ts
.derived
=
4147 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4149 tmp_sym
->ts
.derived
=
4150 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4152 if (tmp_sym
->ts
.derived
== NULL
)
4154 /* Create the necessary derived type so we can continue
4155 processing the file. */
4156 generate_isocbinding_symbol
4157 (mod_name
, s
== ISOCBINDING_FUNLOC
4158 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4159 (const char *)(s
== ISOCBINDING_FUNLOC
4160 ? "_gfortran_iso_c_binding_c_funptr"
4161 : "_gfortran_iso_c_binding_c_ptr"));
4162 tmp_sym
->ts
.derived
=
4163 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4164 ? ISOCBINDING_FUNPTR
4168 /* The function result is itself (no result clause). */
4169 tmp_sym
->result
= tmp_sym
;
4170 tmp_sym
->attr
.external
= 1;
4171 tmp_sym
->attr
.use_assoc
= 0;
4172 tmp_sym
->attr
.pure
= 1;
4173 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4174 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4178 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4179 tmp_sym
->attr
.contained
= 0;
4181 /* Try using this builder routine, with the new and old symbols
4182 both being the generic iso_c proc sym being created. This
4183 will create the formal args (and the new namespace for them).
4184 Don't build an arg list for c_loc because we're going to treat
4185 c_loc as an external procedure. */
4186 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4187 /* The 1 says to add any optional args, if applicable. */
4188 build_formal_args (tmp_sym
, tmp_sym
, 1);
4190 /* Set this after setting up the symbol, to prevent error messages. */
4191 tmp_sym
->attr
.use_assoc
= 1;
4193 /* This symbol will not be referenced directly. It will be
4194 resolved to the implementation for the given f90 kind. */
4195 tmp_sym
->attr
.referenced
= 0;
4205 /* Creates a new symbol based off of an old iso_c symbol, with a new
4206 binding label. This function can be used to create a new,
4207 resolved, version of a procedure symbol for c_f_pointer or
4208 c_f_procpointer that is based on the generic symbols. A new
4209 parameter list is created for the new symbol using
4210 build_formal_args(). The add_optional_flag specifies whether the
4211 to add the optional SHAPE argument. The new symbol is
4215 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4216 char *new_binding_label
, int add_optional_arg
)
4218 gfc_symtree
*new_symtree
= NULL
;
4220 /* See if we have a symbol by that name already available, looking
4221 through any parent namespaces. */
4222 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4223 if (new_symtree
!= NULL
)
4224 /* Return the existing symbol. */
4225 return new_symtree
->n
.sym
;
4227 /* Create the symtree/symbol, with attempted host association. */
4228 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4229 if (new_symtree
== NULL
)
4230 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4231 "symtree for '%s'", new_name
);
4233 /* Now fill in the fields of the resolved symbol with the old sym. */
4234 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4235 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4236 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4237 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4238 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4239 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4240 /* Build the formal arg list. */
4241 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4243 gfc_commit_symbol (new_symtree
->n
.sym
);
4245 return new_symtree
->n
.sym
;
4249 /* Check that a symbol is already typed. If strict is not set, an untyped
4250 symbol is acceptable for non-standard-conforming mode. */
4253 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4254 bool strict
, locus where
)
4258 if (gfc_matching_prefix
)
4261 /* Check for the type and try to give it an implicit one. */
4262 if (sym
->ts
.type
== BT_UNKNOWN
4263 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4267 gfc_error ("Symbol '%s' is used before it is typed at %L",
4272 if (gfc_notify_std (GFC_STD_GNU
,
4273 "Extension: Symbol '%s' is used before"
4274 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4278 /* Everything is ok. */
4283 /* Get the super-type of a given derived type. */
4286 gfc_get_derived_super_type (gfc_symbol
* derived
)
4288 if (!derived
->attr
.extension
)
4291 gcc_assert (derived
->components
);
4292 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4293 gcc_assert (derived
->components
->ts
.derived
);
4295 return derived
->components
->ts
.derived
;
4299 /* Find a type-bound procedure by name for a derived-type (looking recursively
4300 through the super-types). */
4303 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
4304 const char* name
, bool noaccess
)
4308 /* Set default to failure. */
4312 /* Try to find it in the current type's namespace. */
4313 gcc_assert (derived
->f2k_derived
);
4314 res
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4315 if (res
&& res
->typebound
)
4321 if (!noaccess
&& derived
->attr
.use_assoc
4322 && res
->typebound
->access
== ACCESS_PRIVATE
)
4324 gfc_error ("'%s' of '%s' is PRIVATE at %C", name
, derived
->name
);
4332 /* Otherwise, recurse on parent type if derived is an extension. */
4333 if (derived
->attr
.extension
)
4335 gfc_symbol
* super_type
;
4336 super_type
= gfc_get_derived_super_type (derived
);
4337 gcc_assert (super_type
);
4338 return gfc_find_typebound_proc (super_type
, t
, name
, noaccess
);
4341 /* Nothing found. */