1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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/>. */
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
81 const mstring save_status
[] =
83 minit ("UNKNOWN", SAVE_NONE
),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order
= 1;
94 gfc_namespace
*gfc_current_ns
;
96 gfc_gsymbol
*gfc_gsym_root
= NULL
;
98 static gfc_symbol
*changed_syms
= NULL
;
100 gfc_dt_list
*gfc_derived_types
;
103 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
105 /* The following static variable indicates whether a particular element has
106 been explicitly set or not. */
108 static int new_flag
[GFC_LETTERS
];
111 /* Handle a correctly parsed IMPLICIT NONE. */
114 gfc_set_implicit_none (void)
118 if (gfc_current_ns
->seen_implicit_none
)
120 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
124 gfc_current_ns
->seen_implicit_none
= 1;
126 for (i
= 0; i
< GFC_LETTERS
; i
++)
128 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
129 gfc_current_ns
->set_flag
[i
] = 1;
134 /* Reset the implicit range flags. */
137 gfc_clear_new_implicit (void)
141 for (i
= 0; i
< GFC_LETTERS
; i
++)
146 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
149 gfc_add_new_implicit_range (int c1
, int c2
)
156 for (i
= c1
; i
<= c2
; i
++)
160 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
172 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
173 the new implicit types back into the existing types will work. */
176 gfc_merge_new_implicit (gfc_typespec
*ts
)
180 if (gfc_current_ns
->seen_implicit_none
)
182 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
186 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",
197 gfc_current_ns
->default_type
[i
] = *ts
;
198 gfc_current_ns
->set_flag
[i
] = 1;
205 /* Given a symbol, return a pointer to the typespec for its default type. */
208 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
212 letter
= sym
->name
[0];
214 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
215 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
216 "gfortran developers, and should not be used for "
217 "implicitly typed variables");
219 if (letter
< 'a' || letter
> 'z')
220 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
225 return &ns
->default_type
[letter
- 'a'];
229 /* Given a pointer to a symbol, set its type according to the first
230 letter of its name. Fails if the letter in question has no default
234 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
238 if (sym
->ts
.type
!= BT_UNKNOWN
)
239 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
241 ts
= gfc_get_default_type (sym
, ns
);
243 if (ts
->type
== BT_UNKNOWN
)
245 if (error_flag
&& !sym
->attr
.untyped
)
247 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
248 sym
->name
, &sym
->declared_at
);
249 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
256 sym
->attr
.implicit_type
= 1;
258 if (sym
->attr
.is_bind_c
== 1)
260 /* BIND(C) variables should not be implicitly declared. */
261 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
262 "not be C interoperable", sym
->name
, &sym
->declared_at
);
263 sym
->ts
.f90_type
= sym
->ts
.type
;
266 if (sym
->attr
.dummy
!= 0)
268 if (sym
->ns
->proc_name
!= NULL
269 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
270 || sym
->ns
->proc_name
->attr
.function
!= 0)
271 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
273 /* Dummy args to a BIND(C) routine may not be interoperable if
274 they are implicitly typed. */
275 gfc_warning_now ("Implicity declared variable '%s' at %L may not "
276 "be C interoperable but it is a dummy argument to "
277 "the BIND(C) procedure '%s' at %L", sym
->name
,
278 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
279 &(sym
->ns
->proc_name
->declared_at
));
280 sym
->ts
.f90_type
= sym
->ts
.type
;
288 /* This function is called from parse.c(parse_progunit) to check the
289 type of the function is not implicitly typed in the host namespace
290 and to implicitly type the function result, if necessary. */
293 gfc_check_function_type (gfc_namespace
*ns
)
295 gfc_symbol
*proc
= ns
->proc_name
;
297 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
300 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
302 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
305 if (proc
->result
!= proc
)
307 proc
->ts
= proc
->result
->ts
;
308 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
309 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
310 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
311 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
316 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
317 proc
->result
->name
, &proc
->result
->declared_at
);
318 proc
->result
->attr
.untyped
= 1;
324 /******************** Symbol attribute stuff *********************/
326 /* This is a generic conflict-checker. We do this to avoid having a
327 single conflict in two places. */
329 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
330 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
331 #define conf_std(a, b, std) if (attr->a && attr->b)\
340 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
342 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
343 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
344 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
345 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
346 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
347 *private = "PRIVATE", *recursive
= "RECURSIVE",
348 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
349 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
350 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
351 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
352 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
353 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
354 *volatile_
= "VOLATILE", *protected = "PROTECTED",
355 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE";
356 static const char *threadprivate
= "THREADPRIVATE";
362 where
= &gfc_current_locus
;
364 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
368 standard
= GFC_STD_F2003
;
372 /* Check for attributes not allowed in a BLOCK DATA. */
373 if (gfc_current_state () == COMP_BLOCK_DATA
)
377 if (attr
->in_namelist
)
379 if (attr
->allocatable
)
385 if (attr
->access
== ACCESS_PRIVATE
)
387 if (attr
->access
== ACCESS_PUBLIC
)
389 if (attr
->intent
!= INTENT_UNKNOWN
)
395 ("%s attribute not allowed in BLOCK DATA program unit at %L",
401 if (attr
->save
== SAVE_EXPLICIT
)
404 conf (in_common
, save
);
407 switch (attr
->flavor
)
416 a1
= gfc_code2string (flavors
, attr
->flavor
);
428 conf (dummy
, intrinsic
);
429 conf (dummy
, threadprivate
);
430 conf (pointer
, target
);
431 conf (pointer
, intrinsic
);
432 conf (pointer
, elemental
);
433 conf (allocatable
, elemental
);
435 conf (target
, external
);
436 conf (target
, intrinsic
);
437 conf (external
, dimension
); /* See Fortran 95's R504. */
439 conf (external
, intrinsic
);
440 conf (entry
, intrinsic
);
442 if ((attr
->if_source
&& !attr
->procedure
) || attr
->contained
)
444 conf (external
, subroutine
);
445 conf (external
, function
);
448 conf (allocatable
, pointer
);
449 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
450 conf_std (allocatable
, function
, GFC_STD_F2003
);
451 conf_std (allocatable
, result
, GFC_STD_F2003
);
452 conf (elemental
, recursive
);
454 conf (in_common
, dummy
);
455 conf (in_common
, allocatable
);
456 conf (in_common
, result
);
458 conf (dummy
, result
);
460 conf (in_equivalence
, use_assoc
);
461 conf (in_equivalence
, dummy
);
462 conf (in_equivalence
, target
);
463 conf (in_equivalence
, pointer
);
464 conf (in_equivalence
, function
);
465 conf (in_equivalence
, result
);
466 conf (in_equivalence
, entry
);
467 conf (in_equivalence
, allocatable
);
468 conf (in_equivalence
, threadprivate
);
470 conf (in_namelist
, pointer
);
471 conf (in_namelist
, allocatable
);
473 conf (entry
, result
);
475 conf (function
, subroutine
);
477 if (!function
&& !subroutine
)
478 conf (is_bind_c
, dummy
);
480 conf (is_bind_c
, cray_pointer
);
481 conf (is_bind_c
, cray_pointee
);
482 conf (is_bind_c
, allocatable
);
483 conf (is_bind_c
, elemental
);
485 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
486 Parameter conflict caught below. Also, value cannot be specified
487 for a dummy procedure. */
489 /* Cray pointer/pointee conflicts. */
490 conf (cray_pointer
, cray_pointee
);
491 conf (cray_pointer
, dimension
);
492 conf (cray_pointer
, pointer
);
493 conf (cray_pointer
, target
);
494 conf (cray_pointer
, allocatable
);
495 conf (cray_pointer
, external
);
496 conf (cray_pointer
, intrinsic
);
497 conf (cray_pointer
, in_namelist
);
498 conf (cray_pointer
, function
);
499 conf (cray_pointer
, subroutine
);
500 conf (cray_pointer
, entry
);
502 conf (cray_pointee
, allocatable
);
503 conf (cray_pointee
, intent
);
504 conf (cray_pointee
, optional
);
505 conf (cray_pointee
, dummy
);
506 conf (cray_pointee
, target
);
507 conf (cray_pointee
, intrinsic
);
508 conf (cray_pointee
, pointer
);
509 conf (cray_pointee
, entry
);
510 conf (cray_pointee
, in_common
);
511 conf (cray_pointee
, in_equivalence
);
512 conf (cray_pointee
, threadprivate
);
515 conf (data
, function
);
517 conf (data
, allocatable
);
518 conf (data
, use_assoc
);
520 conf (value
, pointer
)
521 conf (value
, allocatable
)
522 conf (value
, subroutine
)
523 conf (value
, function
)
524 conf (value
, volatile_
)
525 conf (value
, dimension
)
526 conf (value
, external
)
529 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
532 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
536 conf (protected, intrinsic
)
537 conf (protected, external
)
538 conf (protected, in_common
)
540 conf (volatile_
, intrinsic
)
541 conf (volatile_
, external
)
543 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
550 conf (procedure
, allocatable
)
551 conf (procedure
, dimension
)
552 conf (procedure
, intrinsic
)
553 conf (procedure
, protected)
554 conf (procedure
, target
)
555 conf (procedure
, value
)
556 conf (procedure
, volatile_
)
557 conf (procedure
, entry
)
558 /* TODO: Implement procedure pointers. */
559 if (attr
->procedure
&& attr
->pointer
)
561 gfc_error ("Fortran 2003: Procedure pointers at %L are "
562 "not yet implemented in gfortran", where
);
566 a1
= gfc_code2string (flavors
, attr
->flavor
);
568 if (attr
->in_namelist
569 && attr
->flavor
!= FL_VARIABLE
570 && attr
->flavor
!= FL_PROCEDURE
571 && attr
->flavor
!= FL_UNKNOWN
)
577 switch (attr
->flavor
)
597 conf2 (threadprivate
);
607 if (attr
->subroutine
)
616 conf2 (threadprivate
);
621 case PROC_ST_FUNCTION
:
633 conf2 (threadprivate
);
653 conf2 (threadprivate
);
655 if (attr
->intent
!= INTENT_UNKNOWN
)
677 conf2 (threadprivate
);
690 gfc_error ("%s attribute conflicts with %s attribute at %L",
693 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
694 a1
, a2
, name
, where
);
701 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
702 "with %s attribute at %L", a1
, a2
,
707 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
708 "with %s attribute in '%s' at %L",
709 a1
, a2
, name
, where
);
718 /* Mark a symbol as referenced. */
721 gfc_set_sym_referenced (gfc_symbol
*sym
)
724 if (sym
->attr
.referenced
)
727 sym
->attr
.referenced
= 1;
729 /* Remember which order dummy variables are accessed in. */
731 sym
->dummy_order
= next_dummy_order
++;
735 /* Common subroutine called by attribute changing subroutines in order
736 to prevent them from changing a symbol that has been
737 use-associated. Returns zero if it is OK to change the symbol,
741 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
744 if (attr
->use_assoc
== 0)
748 where
= &gfc_current_locus
;
751 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
754 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
761 /* Generate an error because of a duplicate attribute. */
764 duplicate_attr (const char *attr
, locus
*where
)
768 where
= &gfc_current_locus
;
770 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
774 /* Called from decl.c (attr_decl1) to check attributes, when declared
778 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
781 if (check_used (attr
, NULL
, where
))
784 return check_conflict (attr
, NULL
, where
);
788 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
791 if (check_used (attr
, NULL
, where
))
794 if (attr
->allocatable
)
796 duplicate_attr ("ALLOCATABLE", where
);
800 attr
->allocatable
= 1;
801 return check_conflict (attr
, NULL
, where
);
806 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
809 if (check_used (attr
, name
, where
))
814 duplicate_attr ("DIMENSION", where
);
819 return check_conflict (attr
, name
, where
);
824 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
827 if (check_used (attr
, NULL
, where
))
832 duplicate_attr ("EXTERNAL", where
);
838 return check_conflict (attr
, NULL
, where
);
843 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
846 if (check_used (attr
, NULL
, where
))
851 duplicate_attr ("INTRINSIC", where
);
857 return check_conflict (attr
, NULL
, where
);
862 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
865 if (check_used (attr
, NULL
, where
))
870 duplicate_attr ("OPTIONAL", where
);
875 return check_conflict (attr
, NULL
, where
);
880 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
883 if (check_used (attr
, NULL
, where
))
887 return check_conflict (attr
, NULL
, where
);
892 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
895 if (check_used (attr
, NULL
, where
))
898 attr
->cray_pointer
= 1;
899 return check_conflict (attr
, NULL
, where
);
904 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
907 if (check_used (attr
, NULL
, where
))
910 if (attr
->cray_pointee
)
912 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
913 " statements", where
);
917 attr
->cray_pointee
= 1;
918 return check_conflict (attr
, NULL
, where
);
923 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
925 if (check_used (attr
, name
, where
))
930 if (gfc_notify_std (GFC_STD_LEGACY
,
931 "Duplicate PROTECTED attribute specified at %L",
938 return check_conflict (attr
, name
, where
);
943 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
946 if (check_used (attr
, name
, where
))
950 return check_conflict (attr
, name
, where
);
955 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
958 if (check_used (attr
, name
, where
))
964 ("SAVE attribute at %L cannot be specified in a PURE procedure",
969 if (attr
->save
== SAVE_EXPLICIT
)
971 if (gfc_notify_std (GFC_STD_LEGACY
,
972 "Duplicate SAVE attribute specified at %L",
978 attr
->save
= SAVE_EXPLICIT
;
979 return check_conflict (attr
, name
, where
);
984 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
987 if (check_used (attr
, name
, where
))
992 if (gfc_notify_std (GFC_STD_LEGACY
,
993 "Duplicate VALUE attribute specified at %L",
1000 return check_conflict (attr
, name
, where
);
1005 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1007 /* No check_used needed as 11.2.1 of the F2003 standard allows
1008 that the local identifier made accessible by a use statement can be
1009 given a VOLATILE attribute. */
1011 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1012 if (gfc_notify_std (GFC_STD_LEGACY
,
1013 "Duplicate VOLATILE attribute specified at %L", where
)
1017 attr
->volatile_
= 1;
1018 attr
->volatile_ns
= gfc_current_ns
;
1019 return check_conflict (attr
, name
, where
);
1024 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1027 if (check_used (attr
, name
, where
))
1030 if (attr
->threadprivate
)
1032 duplicate_attr ("THREADPRIVATE", where
);
1036 attr
->threadprivate
= 1;
1037 return check_conflict (attr
, name
, where
);
1042 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1045 if (check_used (attr
, NULL
, where
))
1050 duplicate_attr ("TARGET", where
);
1055 return check_conflict (attr
, NULL
, where
);
1060 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1063 if (check_used (attr
, name
, where
))
1066 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1068 return check_conflict (attr
, name
, where
);
1073 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1076 if (check_used (attr
, name
, where
))
1079 /* Duplicate attribute already checked for. */
1080 attr
->in_common
= 1;
1081 if (check_conflict (attr
, name
, where
) == FAILURE
)
1084 if (attr
->flavor
== FL_VARIABLE
)
1087 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1092 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1095 /* Duplicate attribute already checked for. */
1096 attr
->in_equivalence
= 1;
1097 if (check_conflict (attr
, name
, where
) == FAILURE
)
1100 if (attr
->flavor
== FL_VARIABLE
)
1103 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1108 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1111 if (check_used (attr
, name
, where
))
1115 return check_conflict (attr
, name
, where
);
1120 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1123 attr
->in_namelist
= 1;
1124 return check_conflict (attr
, name
, where
);
1129 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1132 if (check_used (attr
, name
, where
))
1136 return check_conflict (attr
, name
, where
);
1141 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1144 if (check_used (attr
, NULL
, where
))
1147 if (attr
->elemental
)
1149 duplicate_attr ("ELEMENTAL", where
);
1153 attr
->elemental
= 1;
1154 return check_conflict (attr
, NULL
, where
);
1159 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1162 if (check_used (attr
, NULL
, where
))
1167 duplicate_attr ("PURE", where
);
1172 return check_conflict (attr
, NULL
, where
);
1177 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1180 if (check_used (attr
, NULL
, where
))
1183 if (attr
->recursive
)
1185 duplicate_attr ("RECURSIVE", where
);
1189 attr
->recursive
= 1;
1190 return check_conflict (attr
, NULL
, where
);
1195 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1198 if (check_used (attr
, name
, where
))
1203 duplicate_attr ("ENTRY", where
);
1208 return check_conflict (attr
, name
, where
);
1213 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1216 if (attr
->flavor
!= FL_PROCEDURE
1217 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1221 return check_conflict (attr
, name
, where
);
1226 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1229 if (attr
->flavor
!= FL_PROCEDURE
1230 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1233 attr
->subroutine
= 1;
1234 return check_conflict (attr
, name
, where
);
1239 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1242 if (attr
->flavor
!= FL_PROCEDURE
1243 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1247 return check_conflict (attr
, name
, where
);
1252 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1255 if (check_used (attr
, NULL
, where
))
1258 if (attr
->flavor
!= FL_PROCEDURE
1259 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1262 if (attr
->procedure
)
1264 duplicate_attr ("PROCEDURE", where
);
1268 attr
->procedure
= 1;
1270 return check_conflict (attr
, NULL
, where
);
1274 /* Flavors are special because some flavors are not what Fortran
1275 considers attributes and can be reaffirmed multiple times. */
1278 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1282 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1283 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1284 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1287 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1290 if (attr
->flavor
!= FL_UNKNOWN
)
1293 where
= &gfc_current_locus
;
1296 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1297 gfc_code2string (flavors
, attr
->flavor
), name
,
1298 gfc_code2string (flavors
, f
), where
);
1300 gfc_error ("%s attribute conflicts with %s attribute at %L",
1301 gfc_code2string (flavors
, attr
->flavor
),
1302 gfc_code2string (flavors
, f
), where
);
1309 return check_conflict (attr
, name
, where
);
1314 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1315 const char *name
, locus
*where
)
1318 if (check_used (attr
, name
, where
))
1321 if (attr
->flavor
!= FL_PROCEDURE
1322 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1326 where
= &gfc_current_locus
;
1328 if (attr
->proc
!= PROC_UNKNOWN
)
1330 gfc_error ("%s procedure at %L is already declared as %s procedure",
1331 gfc_code2string (procedures
, t
), where
,
1332 gfc_code2string (procedures
, attr
->proc
));
1339 /* Statement functions are always scalar and functions. */
1340 if (t
== PROC_ST_FUNCTION
1341 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1342 || attr
->dimension
))
1345 return check_conflict (attr
, name
, where
);
1350 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1353 if (check_used (attr
, NULL
, where
))
1356 if (attr
->intent
== INTENT_UNKNOWN
)
1358 attr
->intent
= intent
;
1359 return check_conflict (attr
, NULL
, where
);
1363 where
= &gfc_current_locus
;
1365 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1366 gfc_intent_string (attr
->intent
),
1367 gfc_intent_string (intent
), where
);
1373 /* No checks for use-association in public and private statements. */
1376 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1377 const char *name
, locus
*where
)
1380 if (attr
->access
== ACCESS_UNKNOWN
)
1382 attr
->access
= access
;
1383 return check_conflict (attr
, name
, where
);
1387 where
= &gfc_current_locus
;
1388 gfc_error ("ACCESS specification at %L was already specified", where
);
1394 /* Set the is_bind_c field for the given symbol_attribute. */
1397 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1398 int is_proc_lang_bind_spec
)
1401 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1402 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1403 "variables or common blocks", where
);
1404 else if (attr
->is_bind_c
)
1405 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1407 attr
->is_bind_c
= 1;
1410 where
= &gfc_current_locus
;
1412 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1416 return check_conflict (attr
, name
, where
);
1421 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1422 gfc_formal_arglist
* formal
, locus
*where
)
1425 if (check_used (&sym
->attr
, sym
->name
, where
))
1429 where
= &gfc_current_locus
;
1431 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1432 && sym
->attr
.if_source
!= IFSRC_DECL
)
1434 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1439 sym
->formal
= formal
;
1440 sym
->attr
.if_source
= source
;
1446 /* Add a type to a symbol. */
1449 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1454 where
= &gfc_current_locus
;
1456 if (sym
->ts
.type
!= BT_UNKNOWN
)
1458 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1459 if (!(sym
->ts
.type
== ts
->type
1460 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1461 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1464 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1467 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1468 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1472 flavor
= sym
->attr
.flavor
;
1474 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1475 || flavor
== FL_LABEL
1476 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1477 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1479 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1488 /* Clears all attributes. */
1491 gfc_clear_attr (symbol_attribute
*attr
)
1493 memset (attr
, 0, sizeof (symbol_attribute
));
1497 /* Check for missing attributes in the new symbol. Currently does
1498 nothing, but it's not clear that it is unnecessary yet. */
1501 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1502 locus
*where ATTRIBUTE_UNUSED
)
1509 /* Copy an attribute to a symbol attribute, bit by bit. Some
1510 attributes have a lot of side-effects but cannot be present given
1511 where we are called from, so we ignore some bits. */
1514 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1516 int is_proc_lang_bind_spec
;
1518 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1521 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1523 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1525 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1527 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1529 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1531 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1533 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1535 if (src
->threadprivate
1536 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1538 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1540 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1542 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1547 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1550 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1553 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1555 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1557 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1560 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1562 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1564 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1566 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1569 if (src
->flavor
!= FL_UNKNOWN
1570 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1573 if (src
->intent
!= INTENT_UNKNOWN
1574 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1577 if (src
->access
!= ACCESS_UNKNOWN
1578 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1581 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1584 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1586 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1589 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1591 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1595 if (src
->is_c_interop
)
1596 dest
->is_c_interop
= 1;
1600 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1602 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1612 /************** Component name management ************/
1614 /* Component names of a derived type form their own little namespaces
1615 that are separate from all other spaces. The space is composed of
1616 a singly linked list of gfc_component structures whose head is
1617 located in the parent symbol. */
1620 /* Add a component name to a symbol. The call fails if the name is
1621 already present. On success, the component pointer is modified to
1622 point to the additional component structure. */
1625 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1626 gfc_component
**component
)
1628 gfc_component
*p
, *tail
;
1632 for (p
= sym
->components
; p
; p
= p
->next
)
1634 if (strcmp (p
->name
, name
) == 0)
1636 gfc_error ("Component '%s' at %C already declared at %L",
1644 /* Allocate a new component. */
1645 p
= gfc_get_component ();
1648 sym
->components
= p
;
1652 p
->name
= gfc_get_string (name
);
1653 p
->loc
= gfc_current_locus
;
1660 /* Recursive function to switch derived types of all symbol in a
1664 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1672 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1673 sym
->ts
.derived
= to
;
1675 switch_types (st
->left
, from
, to
);
1676 switch_types (st
->right
, from
, to
);
1680 /* This subroutine is called when a derived type is used in order to
1681 make the final determination about which version to use. The
1682 standard requires that a type be defined before it is 'used', but
1683 such types can appear in IMPLICIT statements before the actual
1684 definition. 'Using' in this context means declaring a variable to
1685 be that type or using the type constructor.
1687 If a type is used and the components haven't been defined, then we
1688 have to have a derived type in a parent unit. We find the node in
1689 the other namespace and point the symtree node in this namespace to
1690 that node. Further reference to this name point to the correct
1691 node. If we can't find the node in a parent namespace, then we have
1694 This subroutine takes a pointer to a symbol node and returns a
1695 pointer to the translated node or NULL for an error. Usually there
1696 is no translation and we return the node we were passed. */
1699 gfc_use_derived (gfc_symbol
*sym
)
1706 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1707 return sym
; /* Already defined. */
1709 if (sym
->ns
->parent
== NULL
)
1712 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1714 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1718 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1721 /* Get rid of symbol sym, translating all references to s. */
1722 for (i
= 0; i
< GFC_LETTERS
; i
++)
1724 t
= &sym
->ns
->default_type
[i
];
1725 if (t
->derived
== sym
)
1729 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1734 /* Unlink from list of modified symbols. */
1735 gfc_commit_symbol (sym
);
1737 switch_types (sym
->ns
->sym_root
, sym
, s
);
1739 /* TODO: Also have to replace sym -> s in other lists like
1740 namelists, common lists and interface lists. */
1741 gfc_free_symbol (sym
);
1746 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1752 /* Given a derived type node and a component name, try to locate the
1753 component structure. Returns the NULL pointer if the component is
1754 not found or the components are private. */
1757 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1764 sym
= gfc_use_derived (sym
);
1769 for (p
= sym
->components
; p
; p
= p
->next
)
1770 if (strcmp (p
->name
, name
) == 0)
1774 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1778 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1779 || p
->access
== ACCESS_PRIVATE
))
1781 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1791 /* Given a symbol, free all of the component structures and everything
1795 free_components (gfc_component
*p
)
1803 gfc_free_array_spec (p
->as
);
1804 gfc_free_expr (p
->initializer
);
1811 /* Set component attributes from a standard symbol attribute structure. */
1814 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1817 c
->dimension
= attr
->dimension
;
1818 c
->pointer
= attr
->pointer
;
1819 c
->allocatable
= attr
->allocatable
;
1820 c
->access
= attr
->access
;
1824 /* Get a standard symbol attribute structure given the component
1828 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1831 gfc_clear_attr (attr
);
1832 attr
->dimension
= c
->dimension
;
1833 attr
->pointer
= c
->pointer
;
1834 attr
->allocatable
= c
->allocatable
;
1835 attr
->access
= c
->access
;
1839 /******************** Statement label management ********************/
1841 /* Comparison function for statement labels, used for managing the
1845 compare_st_labels (void *a1
, void *b1
)
1847 int a
= ((gfc_st_label
*) a1
)->value
;
1848 int b
= ((gfc_st_label
*) b1
)->value
;
1854 /* Free a single gfc_st_label structure, making sure the tree is not
1855 messed up. This function is called only when some parse error
1859 gfc_free_st_label (gfc_st_label
*label
)
1865 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1867 if (label
->format
!= NULL
)
1868 gfc_free_expr (label
->format
);
1874 /* Free a whole tree of gfc_st_label structures. */
1877 free_st_labels (gfc_st_label
*label
)
1883 free_st_labels (label
->left
);
1884 free_st_labels (label
->right
);
1886 if (label
->format
!= NULL
)
1887 gfc_free_expr (label
->format
);
1892 /* Given a label number, search for and return a pointer to the label
1893 structure, creating it if it does not exist. */
1896 gfc_get_st_label (int labelno
)
1900 /* First see if the label is already in this namespace. */
1901 lp
= gfc_current_ns
->st_labels
;
1904 if (lp
->value
== labelno
)
1907 if (lp
->value
< labelno
)
1913 lp
= gfc_getmem (sizeof (gfc_st_label
));
1915 lp
->value
= labelno
;
1916 lp
->defined
= ST_LABEL_UNKNOWN
;
1917 lp
->referenced
= ST_LABEL_UNKNOWN
;
1919 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1925 /* Called when a statement with a statement label is about to be
1926 accepted. We add the label to the list of the current namespace,
1927 making sure it hasn't been defined previously and referenced
1931 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1935 labelno
= lp
->value
;
1937 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1938 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1939 &lp
->where
, label_locus
);
1942 lp
->where
= *label_locus
;
1946 case ST_LABEL_FORMAT
:
1947 if (lp
->referenced
== ST_LABEL_TARGET
)
1948 gfc_error ("Label %d at %C already referenced as branch target",
1951 lp
->defined
= ST_LABEL_FORMAT
;
1955 case ST_LABEL_TARGET
:
1956 if (lp
->referenced
== ST_LABEL_FORMAT
)
1957 gfc_error ("Label %d at %C already referenced as a format label",
1960 lp
->defined
= ST_LABEL_TARGET
;
1965 lp
->defined
= ST_LABEL_BAD_TARGET
;
1966 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1972 /* Reference a label. Given a label and its type, see if that
1973 reference is consistent with what is known about that label,
1974 updating the unknown state. Returns FAILURE if something goes
1978 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1980 gfc_sl_type label_type
;
1987 labelno
= lp
->value
;
1989 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1990 label_type
= lp
->defined
;
1993 label_type
= lp
->referenced
;
1994 lp
->where
= gfc_current_locus
;
1997 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1999 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2004 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2005 && type
== ST_LABEL_FORMAT
)
2007 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2012 lp
->referenced
= type
;
2020 /*******A helper function for creating new expressions*************/
2024 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2027 lval
= gfc_get_expr ();
2028 lval
->expr_type
= EXPR_VARIABLE
;
2029 lval
->where
= sym
->declared_at
;
2031 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2033 /* It will always be a full array. */
2034 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2037 lval
->ref
= gfc_get_ref ();
2038 lval
->ref
->type
= REF_ARRAY
;
2039 lval
->ref
->u
.ar
.type
= AR_FULL
;
2040 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2041 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2042 lval
->ref
->u
.ar
.as
= sym
->as
;
2049 /************** Symbol table management subroutines ****************/
2051 /* Basic details: Fortran 95 requires a potentially unlimited number
2052 of distinct namespaces when compiling a program unit. This case
2053 occurs during a compilation of internal subprograms because all of
2054 the internal subprograms must be read before we can start
2055 generating code for the host.
2057 Given the tricky nature of the Fortran grammar, we must be able to
2058 undo changes made to a symbol table if the current interpretation
2059 of a statement is found to be incorrect. Whenever a symbol is
2060 looked up, we make a copy of it and link to it. All of these
2061 symbols are kept in a singly linked list so that we can commit or
2062 undo the changes at a later time.
2064 A symtree may point to a symbol node outside of its namespace. In
2065 this case, that symbol has been used as a host associated variable
2066 at some previous time. */
2068 /* Allocate a new namespace structure. Copies the implicit types from
2069 PARENT if PARENT_TYPES is set. */
2072 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2076 gfc_intrinsic_op in
;
2079 ns
= gfc_getmem (sizeof (gfc_namespace
));
2080 ns
->sym_root
= NULL
;
2081 ns
->uop_root
= NULL
;
2082 ns
->default_access
= ACCESS_UNKNOWN
;
2083 ns
->parent
= parent
;
2085 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2086 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2088 /* Initialize default implicit types. */
2089 for (i
= 'a'; i
<= 'z'; i
++)
2091 ns
->set_flag
[i
- 'a'] = 0;
2092 ts
= &ns
->default_type
[i
- 'a'];
2094 if (parent_types
&& ns
->parent
!= NULL
)
2096 /* Copy parent settings. */
2097 *ts
= ns
->parent
->default_type
[i
- 'a'];
2101 if (gfc_option
.flag_implicit_none
!= 0)
2107 if ('i' <= i
&& i
<= 'n')
2109 ts
->type
= BT_INTEGER
;
2110 ts
->kind
= gfc_default_integer_kind
;
2115 ts
->kind
= gfc_default_real_kind
;
2125 /* Comparison function for symtree nodes. */
2128 compare_symtree (void *_st1
, void *_st2
)
2130 gfc_symtree
*st1
, *st2
;
2132 st1
= (gfc_symtree
*) _st1
;
2133 st2
= (gfc_symtree
*) _st2
;
2135 return strcmp (st1
->name
, st2
->name
);
2139 /* Allocate a new symtree node and associate it with the new symbol. */
2142 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2146 st
= gfc_getmem (sizeof (gfc_symtree
));
2147 st
->name
= gfc_get_string (name
);
2149 gfc_insert_bbt (root
, st
, compare_symtree
);
2154 /* Delete a symbol from the tree. Does not free the symbol itself! */
2157 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2159 gfc_symtree st
, *st0
;
2161 st0
= gfc_find_symtree (*root
, name
);
2163 st
.name
= gfc_get_string (name
);
2164 gfc_delete_bbt (root
, &st
, compare_symtree
);
2170 /* Given a root symtree node and a name, try to find the symbol within
2171 the namespace. Returns NULL if the symbol is not found. */
2174 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2180 c
= strcmp (name
, st
->name
);
2184 st
= (c
< 0) ? st
->left
: st
->right
;
2191 /* Return a symtree node with a name that is guaranteed to be unique
2192 within the namespace and corresponds to an illegal fortran name. */
2195 gfc_get_unique_symtree (gfc_namespace
*ns
)
2197 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2198 static int serial
= 0;
2200 sprintf (name
, "@%d", serial
++);
2201 return gfc_new_symtree (&ns
->sym_root
, name
);
2205 /* Given a name find a user operator node, creating it if it doesn't
2206 exist. These are much simpler than symbols because they can't be
2207 ambiguous with one another. */
2210 gfc_get_uop (const char *name
)
2215 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2219 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2221 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2222 uop
->name
= gfc_get_string (name
);
2223 uop
->access
= ACCESS_UNKNOWN
;
2224 uop
->ns
= gfc_current_ns
;
2230 /* Given a name find the user operator node. Returns NULL if it does
2234 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2239 ns
= gfc_current_ns
;
2241 st
= gfc_find_symtree (ns
->uop_root
, name
);
2242 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2246 /* Remove a gfc_symbol structure and everything it points to. */
2249 gfc_free_symbol (gfc_symbol
*sym
)
2255 gfc_free_array_spec (sym
->as
);
2257 free_components (sym
->components
);
2259 gfc_free_expr (sym
->value
);
2261 gfc_free_namelist (sym
->namelist
);
2263 gfc_free_namespace (sym
->formal_ns
);
2265 if (!sym
->attr
.generic_copy
)
2266 gfc_free_interface (sym
->generic
);
2268 gfc_free_formal_arglist (sym
->formal
);
2274 /* Allocate and initialize a new symbol node. */
2277 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2281 p
= gfc_getmem (sizeof (gfc_symbol
));
2283 gfc_clear_ts (&p
->ts
);
2284 gfc_clear_attr (&p
->attr
);
2287 p
->declared_at
= gfc_current_locus
;
2289 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2290 gfc_internal_error ("new_symbol(): Symbol name too long");
2292 p
->name
= gfc_get_string (name
);
2294 /* Make sure flags for symbol being C bound are clear initially. */
2295 p
->attr
.is_bind_c
= 0;
2296 p
->attr
.is_iso_c
= 0;
2297 /* Make sure the binding label field has a Nul char to start. */
2298 p
->binding_label
[0] = '\0';
2300 /* Clear the ptrs we may need. */
2301 p
->common_block
= NULL
;
2307 /* Generate an error if a symbol is ambiguous. */
2310 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2313 if (st
->n
.sym
->module
)
2314 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2315 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2317 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2318 "from current program unit", name
, st
->n
.sym
->name
);
2322 /* Search for a symtree starting in the current namespace, resorting to
2323 any parent namespaces if requested by a nonzero parent_flag.
2324 Returns nonzero if the name is ambiguous. */
2327 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2328 gfc_symtree
**result
)
2333 ns
= gfc_current_ns
;
2337 st
= gfc_find_symtree (ns
->sym_root
, name
);
2341 /* Ambiguous generic interfaces are permitted, as long
2342 as the specific interfaces are different. */
2343 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2345 ambiguous_symbol (name
, st
);
2364 /* Same, but returns the symbol instead. */
2367 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2368 gfc_symbol
**result
)
2373 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2378 *result
= st
->n
.sym
;
2384 /* Save symbol with the information necessary to back it out. */
2387 save_symbol_data (gfc_symbol
*sym
)
2390 if (sym
->new || sym
->old_symbol
!= NULL
)
2393 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2394 *(sym
->old_symbol
) = *sym
;
2396 sym
->tlink
= changed_syms
;
2401 /* Given a name, find a symbol, or create it if it does not exist yet
2402 in the current namespace. If the symbol is found we make sure that
2405 The integer return code indicates
2407 1 The symbol name was ambiguous
2408 2 The name meant to be established was already host associated.
2410 So if the return value is nonzero, then an error was issued. */
2413 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2418 /* This doesn't usually happen during resolution. */
2420 ns
= gfc_current_ns
;
2422 /* Try to find the symbol in ns. */
2423 st
= gfc_find_symtree (ns
->sym_root
, name
);
2427 /* If not there, create a new symbol. */
2428 p
= gfc_new_symbol (name
, ns
);
2430 /* Add to the list of tentative symbols. */
2431 p
->old_symbol
= NULL
;
2432 p
->tlink
= changed_syms
;
2437 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2444 /* Make sure the existing symbol is OK. Ambiguous
2445 generic interfaces are permitted, as long as the
2446 specific interfaces are different. */
2447 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2449 ambiguous_symbol (name
, st
);
2455 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2457 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2458 && (ns
->has_import_set
|| p
->attr
.imported
)))
2460 /* Symbol is from another namespace. */
2461 gfc_error ("Symbol '%s' at %C has already been host associated",
2468 /* Copy in case this symbol is changed. */
2469 save_symbol_data (p
);
2478 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2483 i
= gfc_get_sym_tree (name
, ns
, &st
);
2488 *result
= st
->n
.sym
;
2495 /* Subroutine that searches for a symbol, creating it if it doesn't
2496 exist, but tries to host-associate the symbol if possible. */
2499 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2504 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2507 save_symbol_data (st
->n
.sym
);
2512 if (gfc_current_ns
->parent
!= NULL
)
2514 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2525 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2530 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2535 i
= gfc_get_ha_sym_tree (name
, &st
);
2538 *result
= st
->n
.sym
;
2545 /* Return true if both symbols could refer to the same data object. Does
2546 not take account of aliasing due to equivalence statements. */
2549 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2551 /* Aliasing isn't possible if the symbols have different base types. */
2552 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2555 /* Pointers can point to other pointers, target objects and allocatable
2556 objects. Two allocatable objects cannot share the same storage. */
2557 if (lsym
->attr
.pointer
2558 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2560 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2562 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2569 /* Undoes all the changes made to symbols in the current statement.
2570 This subroutine is made simpler due to the fact that attributes are
2571 never removed once added. */
2574 gfc_undo_symbols (void)
2576 gfc_symbol
*p
, *q
, *old
;
2578 for (p
= changed_syms
; p
; p
= q
)
2584 /* Symbol was new. */
2585 if (p
->attr
.in_common
&& p
->common_block
->head
)
2587 /* If the symbol was added to any common block, it
2588 needs to be removed to stop the resolver looking
2589 for a (possibly) dead symbol. */
2591 if (p
->common_block
->head
== p
)
2592 p
->common_block
->head
= p
->common_next
;
2595 gfc_symbol
*cparent
, *csym
;
2597 cparent
= p
->common_block
->head
;
2598 csym
= cparent
->common_next
;
2603 csym
= csym
->common_next
;
2606 gcc_assert(cparent
->common_next
== p
);
2608 cparent
->common_next
= csym
->common_next
;
2612 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2616 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2618 gfc_free_symbol (p
);
2622 /* Restore previous state of symbol. Just copy simple stuff. */
2624 old
= p
->old_symbol
;
2626 p
->ts
.type
= old
->ts
.type
;
2627 p
->ts
.kind
= old
->ts
.kind
;
2629 p
->attr
= old
->attr
;
2631 if (p
->value
!= old
->value
)
2633 gfc_free_expr (old
->value
);
2637 if (p
->as
!= old
->as
)
2640 gfc_free_array_spec (p
->as
);
2644 p
->generic
= old
->generic
;
2645 p
->component_access
= old
->component_access
;
2647 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2649 gfc_free_namelist (p
->namelist
);
2654 if (p
->namelist_tail
!= old
->namelist_tail
)
2656 gfc_free_namelist (old
->namelist_tail
);
2657 old
->namelist_tail
->next
= NULL
;
2661 p
->namelist_tail
= old
->namelist_tail
;
2663 if (p
->formal
!= old
->formal
)
2665 gfc_free_formal_arglist (p
->formal
);
2666 p
->formal
= old
->formal
;
2669 gfc_free (p
->old_symbol
);
2670 p
->old_symbol
= NULL
;
2674 changed_syms
= NULL
;
2678 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2679 components of old_symbol that might need deallocation are the "allocatables"
2680 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2681 namelist_tail. In case these differ between old_symbol and sym, it's just
2682 because sym->namelist has gotten a few more items. */
2685 free_old_symbol (gfc_symbol
*sym
)
2688 if (sym
->old_symbol
== NULL
)
2691 if (sym
->old_symbol
->as
!= sym
->as
)
2692 gfc_free_array_spec (sym
->old_symbol
->as
);
2694 if (sym
->old_symbol
->value
!= sym
->value
)
2695 gfc_free_expr (sym
->old_symbol
->value
);
2697 if (sym
->old_symbol
->formal
!= sym
->formal
)
2698 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2700 gfc_free (sym
->old_symbol
);
2701 sym
->old_symbol
= NULL
;
2705 /* Makes the changes made in the current statement permanent-- gets
2706 rid of undo information. */
2709 gfc_commit_symbols (void)
2713 for (p
= changed_syms
; p
; p
= q
)
2719 free_old_symbol (p
);
2721 changed_syms
= NULL
;
2725 /* Makes the changes made in one symbol permanent -- gets rid of undo
2729 gfc_commit_symbol (gfc_symbol
*sym
)
2733 if (changed_syms
== sym
)
2734 changed_syms
= sym
->tlink
;
2737 for (p
= changed_syms
; p
; p
= p
->tlink
)
2738 if (p
->tlink
== sym
)
2740 p
->tlink
= sym
->tlink
;
2749 free_old_symbol (sym
);
2753 /* Recursive function that deletes an entire tree and all the common
2754 head structures it points to. */
2757 free_common_tree (gfc_symtree
* common_tree
)
2759 if (common_tree
== NULL
)
2762 free_common_tree (common_tree
->left
);
2763 free_common_tree (common_tree
->right
);
2765 gfc_free (common_tree
);
2769 /* Recursive function that deletes an entire tree and all the user
2770 operator nodes that it contains. */
2773 free_uop_tree (gfc_symtree
*uop_tree
)
2776 if (uop_tree
== NULL
)
2779 free_uop_tree (uop_tree
->left
);
2780 free_uop_tree (uop_tree
->right
);
2782 gfc_free_interface (uop_tree
->n
.uop
->operator);
2784 gfc_free (uop_tree
->n
.uop
);
2785 gfc_free (uop_tree
);
2789 /* Recursive function that deletes an entire tree and all the symbols
2790 that it contains. */
2793 free_sym_tree (gfc_symtree
*sym_tree
)
2798 if (sym_tree
== NULL
)
2801 free_sym_tree (sym_tree
->left
);
2802 free_sym_tree (sym_tree
->right
);
2804 sym
= sym_tree
->n
.sym
;
2808 gfc_internal_error ("free_sym_tree(): Negative refs");
2810 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2812 /* As formal_ns contains a reference to sym, delete formal_ns just
2813 before the deletion of sym. */
2814 ns
= sym
->formal_ns
;
2815 sym
->formal_ns
= NULL
;
2816 gfc_free_namespace (ns
);
2818 else if (sym
->refs
== 0)
2820 /* Go ahead and delete the symbol. */
2821 gfc_free_symbol (sym
);
2824 gfc_free (sym_tree
);
2828 /* Free the derived type list. */
2831 gfc_free_dt_list (void)
2833 gfc_dt_list
*dt
, *n
;
2835 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2841 gfc_derived_types
= NULL
;
2845 /* Free the gfc_equiv_info's. */
2848 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2852 gfc_free_equiv_infos (s
->next
);
2857 /* Free the gfc_equiv_lists. */
2860 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2864 gfc_free_equiv_lists (l
->next
);
2865 gfc_free_equiv_infos (l
->equiv
);
2870 /* Free a namespace structure and everything below it. Interface
2871 lists associated with intrinsic operators are not freed. These are
2872 taken care of when a specific name is freed. */
2875 gfc_free_namespace (gfc_namespace
*ns
)
2877 gfc_charlen
*cl
, *cl2
;
2878 gfc_namespace
*p
, *q
;
2887 gcc_assert (ns
->refs
== 0);
2889 gfc_free_statements (ns
->code
);
2891 free_sym_tree (ns
->sym_root
);
2892 free_uop_tree (ns
->uop_root
);
2893 free_common_tree (ns
->common_root
);
2895 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2898 gfc_free_expr (cl
->length
);
2902 free_st_labels (ns
->st_labels
);
2904 gfc_free_equiv (ns
->equiv
);
2905 gfc_free_equiv_lists (ns
->equiv_lists
);
2907 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2908 gfc_free_interface (ns
->operator[i
]);
2910 gfc_free_data (ns
->data
);
2914 /* Recursively free any contained namespaces. */
2919 gfc_free_namespace (q
);
2925 gfc_symbol_init_2 (void)
2928 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2933 gfc_symbol_done_2 (void)
2936 gfc_free_namespace (gfc_current_ns
);
2937 gfc_current_ns
= NULL
;
2938 gfc_free_dt_list ();
2942 /* Clear mark bits from symbol nodes associated with a symtree node. */
2945 clear_sym_mark (gfc_symtree
*st
)
2948 st
->n
.sym
->mark
= 0;
2952 /* Recursively traverse the symtree nodes. */
2955 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2960 gfc_traverse_symtree (st
->left
, func
);
2962 gfc_traverse_symtree (st
->right
, func
);
2966 /* Recursive namespace traversal function. */
2969 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2975 traverse_ns (st
->left
, func
);
2977 if (st
->n
.sym
->mark
== 0)
2978 (*func
) (st
->n
.sym
);
2979 st
->n
.sym
->mark
= 1;
2981 traverse_ns (st
->right
, func
);
2985 /* Call a given function for all symbols in the namespace. We take
2986 care that each gfc_symbol node is called exactly once. */
2989 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2992 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2994 traverse_ns (ns
->sym_root
, func
);
2998 /* Return TRUE when name is the name of an intrinsic type. */
3001 gfc_is_intrinsic_typename (const char *name
)
3003 if (strcmp (name
, "integer") == 0
3004 || strcmp (name
, "real") == 0
3005 || strcmp (name
, "character") == 0
3006 || strcmp (name
, "logical") == 0
3007 || strcmp (name
, "complex") == 0
3008 || strcmp (name
, "doubleprecision") == 0
3009 || strcmp (name
, "doublecomplex") == 0)
3016 /* Return TRUE if the symbol is an automatic variable. */
3019 gfc_is_var_automatic (gfc_symbol
*sym
)
3021 /* Pointer and allocatable variables are never automatic. */
3022 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3024 /* Check for arrays with non-constant size. */
3025 if (sym
->attr
.dimension
&& sym
->as
3026 && !gfc_is_compile_time_shape (sym
->as
))
3028 /* Check for non-constant length character variables. */
3029 if (sym
->ts
.type
== BT_CHARACTER
3031 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
3036 /* Given a symbol, mark it as SAVEd if it is allowed. */
3039 save_symbol (gfc_symbol
*sym
)
3042 if (sym
->attr
.use_assoc
)
3045 if (sym
->attr
.in_common
3047 || sym
->attr
.flavor
!= FL_VARIABLE
)
3049 /* Automatic objects are not saved. */
3050 if (gfc_is_var_automatic (sym
))
3052 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3056 /* Mark those symbols which can be SAVEd as such. */
3059 gfc_save_all (gfc_namespace
*ns
)
3062 gfc_traverse_ns (ns
, save_symbol
);
3067 /* Make sure that no changes to symbols are pending. */
3070 gfc_symbol_state(void) {
3072 if (changed_syms
!= NULL
)
3073 gfc_internal_error("Symbol changes still pending!");
3078 /************** Global symbol handling ************/
3081 /* Search a tree for the global symbol. */
3084 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3093 c
= strcmp (name
, symbol
->name
);
3097 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3104 /* Compare two global symbols. Used for managing the BB tree. */
3107 gsym_compare (void *_s1
, void *_s2
)
3109 gfc_gsymbol
*s1
, *s2
;
3111 s1
= (gfc_gsymbol
*) _s1
;
3112 s2
= (gfc_gsymbol
*) _s2
;
3113 return strcmp (s1
->name
, s2
->name
);
3117 /* Get a global symbol, creating it if it doesn't exist. */
3120 gfc_get_gsymbol (const char *name
)
3124 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3128 s
= gfc_getmem (sizeof (gfc_gsymbol
));
3129 s
->type
= GSYM_UNKNOWN
;
3130 s
->name
= gfc_get_string (name
);
3132 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3139 get_iso_c_binding_dt (int sym_id
)
3141 gfc_dt_list
*dt_list
;
3143 dt_list
= gfc_derived_types
;
3145 /* Loop through the derived types in the name list, searching for
3146 the desired symbol from iso_c_binding. Search the parent namespaces
3147 if necessary and requested to (parent_flag). */
3148 while (dt_list
!= NULL
)
3150 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3151 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3152 return dt_list
->derived
;
3154 dt_list
= dt_list
->next
;
3161 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3162 with C. This is necessary for any derived type that is BIND(C) and for
3163 derived types that are parameters to functions that are BIND(C). All
3164 fields of the derived type are required to be interoperable, and are tested
3165 for such. If an error occurs, the errors are reported here, allowing for
3166 multiple errors to be handled for a single derived type. */
3169 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3171 gfc_component
*curr_comp
= NULL
;
3172 try is_c_interop
= FAILURE
;
3173 try retval
= SUCCESS
;
3175 if (derived_sym
== NULL
)
3176 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3177 "unexpectedly NULL");
3179 /* If we've already looked at this derived symbol, do not look at it again
3180 so we don't repeat warnings/errors. */
3181 if (derived_sym
->ts
.is_c_interop
)
3184 /* The derived type must have the BIND attribute to be interoperable
3185 J3/04-007, Section 15.2.3. */
3186 if (derived_sym
->attr
.is_bind_c
!= 1)
3188 derived_sym
->ts
.is_c_interop
= 0;
3189 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3190 "attribute to be C interoperable", derived_sym
->name
,
3191 &(derived_sym
->declared_at
));
3195 curr_comp
= derived_sym
->components
;
3197 /* TODO: is this really an error? */
3198 if (curr_comp
== NULL
)
3200 gfc_error ("Derived type '%s' at %L is empty",
3201 derived_sym
->name
, &(derived_sym
->declared_at
));
3205 /* Initialize the derived type as being C interoperable.
3206 If we find an error in the components, this will be set false. */
3207 derived_sym
->ts
.is_c_interop
= 1;
3209 /* Loop through the list of components to verify that the kind of
3210 each is a C interoperable type. */
3213 /* The components cannot be pointers (fortran sense).
3214 J3/04-007, Section 15.2.3, C1505. */
3215 if (curr_comp
->pointer
!= 0)
3217 gfc_error ("Component '%s' at %L cannot have the "
3218 "POINTER attribute because it is a member "
3219 "of the BIND(C) derived type '%s' at %L",
3220 curr_comp
->name
, &(curr_comp
->loc
),
3221 derived_sym
->name
, &(derived_sym
->declared_at
));
3225 /* The components cannot be allocatable.
3226 J3/04-007, Section 15.2.3, C1505. */
3227 if (curr_comp
->allocatable
!= 0)
3229 gfc_error ("Component '%s' at %L cannot have the "
3230 "ALLOCATABLE attribute because it is a member "
3231 "of the BIND(C) derived type '%s' at %L",
3232 curr_comp
->name
, &(curr_comp
->loc
),
3233 derived_sym
->name
, &(derived_sym
->declared_at
));
3237 /* BIND(C) derived types must have interoperable components. */
3238 if (curr_comp
->ts
.type
== BT_DERIVED
3239 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3240 && curr_comp
->ts
.derived
!= derived_sym
)
3242 /* This should be allowed; the draft says a derived-type can not
3243 have type parameters if it is has the BIND attribute. Type
3244 parameters seem to be for making parameterized derived types.
3245 There's no need to verify the type if it is c_ptr/c_funptr. */
3246 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3250 /* Grab the typespec for the given component and test the kind. */
3251 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3254 if (is_c_interop
!= SUCCESS
)
3256 /* Report warning and continue since not fatal. The
3257 draft does specify a constraint that requires all fields
3258 to interoperate, but if the user says real(4), etc., it
3259 may interoperate with *something* in C, but the compiler
3260 most likely won't know exactly what. Further, it may not
3261 interoperate with the same data type(s) in C if the user
3262 recompiles with different flags (e.g., -m32 and -m64 on
3263 x86_64 and using integer(4) to claim interop with a
3265 if (derived_sym
->attr
.is_bind_c
== 1)
3266 /* If the derived type is bind(c), all fields must be
3268 gfc_warning ("Component '%s' in derived type '%s' at %L "
3269 "may not be C interoperable, even though "
3270 "derived type '%s' is BIND(C)",
3271 curr_comp
->name
, derived_sym
->name
,
3272 &(curr_comp
->loc
), derived_sym
->name
);
3274 /* If derived type is param to bind(c) routine, or to one
3275 of the iso_c_binding procs, it must be interoperable, so
3276 all fields must interop too. */
3277 gfc_warning ("Component '%s' in derived type '%s' at %L "
3278 "may not be C interoperable",
3279 curr_comp
->name
, derived_sym
->name
,
3284 curr_comp
= curr_comp
->next
;
3285 } while (curr_comp
!= NULL
);
3288 /* Make sure we don't have conflicts with the attributes. */
3289 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3291 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3292 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3293 &(derived_sym
->declared_at
));
3297 if (derived_sym
->attr
.sequence
!= 0)
3299 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3300 "attribute because it is BIND(C)", derived_sym
->name
,
3301 &(derived_sym
->declared_at
));
3305 /* Mark the derived type as not being C interoperable if we found an
3306 error. If there were only warnings, proceed with the assumption
3307 it's interoperable. */
3308 if (retval
== FAILURE
)
3309 derived_sym
->ts
.is_c_interop
= 0;
3315 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3318 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3319 const char *module_name
)
3321 gfc_symtree
*tmp_symtree
;
3322 gfc_symbol
*tmp_sym
;
3324 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3326 if (tmp_symtree
!= NULL
)
3327 tmp_sym
= tmp_symtree
->n
.sym
;
3331 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3332 "create symbol for %s", ptr_name
);
3335 /* Set up the symbol's important fields. Save attr required so we can
3336 initialize the ptr to NULL. */
3337 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3338 tmp_sym
->ts
.is_c_interop
= 1;
3339 tmp_sym
->attr
.is_c_interop
= 1;
3340 tmp_sym
->ts
.is_iso_c
= 1;
3341 tmp_sym
->ts
.type
= BT_DERIVED
;
3343 /* The c_ptr and c_funptr derived types will provide the
3344 definition for c_null_ptr and c_null_funptr, respectively. */
3345 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3346 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3348 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3349 if (tmp_sym
->ts
.derived
== NULL
)
3351 /* This can occur if the user forgot to declare c_ptr or
3352 c_funptr and they're trying to use one of the procedures
3353 that has arg(s) of the missing type. In this case, a
3354 regular version of the thing should have been put in the
3356 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3357 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3358 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3359 ? "_gfortran_iso_c_binding_c_ptr"
3360 : "_gfortran_iso_c_binding_c_funptr"));
3362 tmp_sym
->ts
.derived
=
3363 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3364 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3367 /* Module name is some mangled version of iso_c_binding. */
3368 tmp_sym
->module
= gfc_get_string (module_name
);
3370 /* Say it's from the iso_c_binding module. */
3371 tmp_sym
->attr
.is_iso_c
= 1;
3373 tmp_sym
->attr
.use_assoc
= 1;
3374 tmp_sym
->attr
.is_bind_c
= 1;
3375 /* Set the binding_label. */
3376 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3378 /* Set the c_address field of c_null_ptr and c_null_funptr to
3379 the value of NULL. */
3380 tmp_sym
->value
= gfc_get_expr ();
3381 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3382 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3383 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3384 /* Create a constructor with no expr, that way we can recognize if the user
3385 tries to call the structure constructor for one of the iso_c_binding
3386 derived types during resolution (resolve_structure_cons). */
3387 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3388 /* Must declare c_null_ptr and c_null_funptr as having the
3389 PARAMETER attribute so they can be used in init expressions. */
3390 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3396 /* Add a formal argument, gfc_formal_arglist, to the
3397 end of the given list of arguments. Set the reference to the
3398 provided symbol, param_sym, in the argument. */
3401 add_formal_arg (gfc_formal_arglist
**head
,
3402 gfc_formal_arglist
**tail
,
3403 gfc_formal_arglist
*formal_arg
,
3404 gfc_symbol
*param_sym
)
3406 /* Put in list, either as first arg or at the tail (curr arg). */
3408 *head
= *tail
= formal_arg
;
3411 (*tail
)->next
= formal_arg
;
3412 (*tail
) = formal_arg
;
3415 (*tail
)->sym
= param_sym
;
3416 (*tail
)->next
= NULL
;
3422 /* Generates a symbol representing the CPTR argument to an
3423 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3424 CPTR and add it to the provided argument list. */
3427 gen_cptr_param (gfc_formal_arglist
**head
,
3428 gfc_formal_arglist
**tail
,
3429 const char *module_name
,
3430 gfc_namespace
*ns
, const char *c_ptr_name
,
3433 gfc_symbol
*param_sym
= NULL
;
3434 gfc_symbol
*c_ptr_sym
= NULL
;
3435 gfc_symtree
*param_symtree
= NULL
;
3436 gfc_formal_arglist
*formal_arg
= NULL
;
3437 const char *c_ptr_in
;
3438 const char *c_ptr_type
= NULL
;
3440 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3441 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3443 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3445 if(c_ptr_name
== NULL
)
3446 c_ptr_in
= "gfc_cptr__";
3448 c_ptr_in
= c_ptr_name
;
3449 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3450 if (param_symtree
!= NULL
)
3451 param_sym
= param_symtree
->n
.sym
;
3453 gfc_internal_error ("gen_cptr_param(): Unable to "
3454 "create symbol for %s", c_ptr_in
);
3456 /* Set up the appropriate fields for the new c_ptr param sym. */
3458 param_sym
->attr
.flavor
= FL_DERIVED
;
3459 param_sym
->ts
.type
= BT_DERIVED
;
3460 param_sym
->attr
.intent
= INTENT_IN
;
3461 param_sym
->attr
.dummy
= 1;
3463 /* This will pass the ptr to the iso_c routines as a (void *). */
3464 param_sym
->attr
.value
= 1;
3465 param_sym
->attr
.use_assoc
= 1;
3467 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3469 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3470 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3472 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3473 if (c_ptr_sym
== NULL
)
3475 /* This can happen if the user did not define c_ptr but they are
3476 trying to use one of the iso_c_binding functions that need it. */
3477 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3478 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3479 (const char *)c_ptr_type
);
3481 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3482 (const char *)c_ptr_type
);
3484 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3487 param_sym
->ts
.derived
= c_ptr_sym
;
3488 param_sym
->module
= gfc_get_string (module_name
);
3490 /* Make new formal arg. */
3491 formal_arg
= gfc_get_formal_arglist ();
3492 /* Add arg to list of formal args (the CPTR arg). */
3493 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3497 /* Generates a symbol representing the FPTR argument to an
3498 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3499 FPTR and add it to the provided argument list. */
3502 gen_fptr_param (gfc_formal_arglist
**head
,
3503 gfc_formal_arglist
**tail
,
3504 const char *module_name
,
3505 gfc_namespace
*ns
, const char *f_ptr_name
)
3507 gfc_symbol
*param_sym
= NULL
;
3508 gfc_symtree
*param_symtree
= NULL
;
3509 gfc_formal_arglist
*formal_arg
= NULL
;
3510 const char *f_ptr_out
= "gfc_fptr__";
3512 if (f_ptr_name
!= NULL
)
3513 f_ptr_out
= f_ptr_name
;
3515 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3516 if (param_symtree
!= NULL
)
3517 param_sym
= param_symtree
->n
.sym
;
3519 gfc_internal_error ("generateFPtrParam(): Unable to "
3520 "create symbol for %s", f_ptr_out
);
3522 /* Set up the necessary fields for the fptr output param sym. */
3524 param_sym
->attr
.pointer
= 1;
3525 param_sym
->attr
.dummy
= 1;
3526 param_sym
->attr
.use_assoc
= 1;
3528 /* ISO C Binding type to allow any pointer type as actual param. */
3529 param_sym
->ts
.type
= BT_VOID
;
3530 param_sym
->module
= gfc_get_string (module_name
);
3533 formal_arg
= gfc_get_formal_arglist ();
3534 /* Add arg to list of formal args. */
3535 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3539 /* Generates a symbol representing the optional SHAPE argument for the
3540 iso_c_binding c_f_pointer() procedure. Also, create a
3541 gfc_formal_arglist for the SHAPE and add it to the provided
3545 gen_shape_param (gfc_formal_arglist
**head
,
3546 gfc_formal_arglist
**tail
,
3547 const char *module_name
,
3548 gfc_namespace
*ns
, const char *shape_param_name
)
3550 gfc_symbol
*param_sym
= NULL
;
3551 gfc_symtree
*param_symtree
= NULL
;
3552 gfc_formal_arglist
*formal_arg
= NULL
;
3553 const char *shape_param
= "gfc_shape_array__";
3556 if (shape_param_name
!= NULL
)
3557 shape_param
= shape_param_name
;
3559 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3560 if (param_symtree
!= NULL
)
3561 param_sym
= param_symtree
->n
.sym
;
3563 gfc_internal_error ("generateShapeParam(): Unable to "
3564 "create symbol for %s", shape_param
);
3566 /* Set up the necessary fields for the shape input param sym. */
3568 param_sym
->attr
.dummy
= 1;
3569 param_sym
->attr
.use_assoc
= 1;
3571 /* Integer array, rank 1, describing the shape of the object. Make it's
3572 type BT_VOID initially so we can accept any type/kind combination of
3573 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3574 of BT_INTEGER type. */
3575 param_sym
->ts
.type
= BT_VOID
;
3577 /* Initialize the kind to default integer. However, it will be overridden
3578 during resolution to match the kind of the SHAPE parameter given as
3579 the actual argument (to allow for any valid integer kind). */
3580 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3581 param_sym
->as
= gfc_get_array_spec ();
3583 /* Clear out the dimension info for the array. */
3584 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3586 param_sym
->as
->lower
[i
] = NULL
;
3587 param_sym
->as
->upper
[i
] = NULL
;
3589 param_sym
->as
->rank
= 1;
3590 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3592 /* The extent is unknown until we get it. The length give us
3593 the rank the incoming pointer. */
3594 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3596 /* The arg is also optional; it is required iff the second arg
3597 (fptr) is to an array, otherwise, it's ignored. */
3598 param_sym
->attr
.optional
= 1;
3599 param_sym
->attr
.intent
= INTENT_IN
;
3600 param_sym
->attr
.dimension
= 1;
3601 param_sym
->module
= gfc_get_string (module_name
);
3604 formal_arg
= gfc_get_formal_arglist ();
3605 /* Add arg to list of formal args. */
3606 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3609 /* Add a procedure interface to the given symbol (i.e., store a
3610 reference to the list of formal arguments). */
3613 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3614 gfc_formal_arglist
*formal
)
3617 sym
->formal
= formal
;
3618 sym
->attr
.if_source
= source
;
3621 /* Copy the formal args from an existing symbol, src, into a new
3622 symbol, dest. New formal args are created, and the description of
3623 each arg is set according to the existing ones. This function is
3624 used when creating procedure declaration variables from a procedure
3625 declaration statement (see match_proc_decl()) to create the formal
3626 args based on the args of a given named interface. */
3628 void copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3630 gfc_formal_arglist
*head
= NULL
;
3631 gfc_formal_arglist
*tail
= NULL
;
3632 gfc_formal_arglist
*formal_arg
= NULL
;
3633 gfc_formal_arglist
*curr_arg
= NULL
;
3634 gfc_formal_arglist
*formal_prev
= NULL
;
3635 /* Save current namespace so we can change it for formal args. */
3636 gfc_namespace
*parent_ns
= gfc_current_ns
;
3638 /* Create a new namespace, which will be the formal ns (namespace
3639 of the formal args). */
3640 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3641 gfc_current_ns
->proc_name
= dest
;
3643 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3645 formal_arg
= gfc_get_formal_arglist ();
3646 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3648 /* May need to copy more info for the symbol. */
3649 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3650 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3652 /* If this isn't the first arg, set up the next ptr. For the
3653 last arg built, the formal_arg->next will never get set to
3654 anything other than NULL. */
3655 if (formal_prev
!= NULL
)
3656 formal_prev
->next
= formal_arg
;
3658 formal_arg
->next
= NULL
;
3660 formal_prev
= formal_arg
;
3662 /* Add arg to list of formal args. */
3663 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3666 /* Add the interface to the symbol. */
3667 add_proc_interface (dest
, IFSRC_DECL
, head
);
3669 /* Store the formal namespace information. */
3670 if (dest
->formal
!= NULL
)
3671 /* The current ns should be that for the dest proc. */
3672 dest
->formal_ns
= gfc_current_ns
;
3673 /* Restore the current namespace to what it was on entry. */
3674 gfc_current_ns
= parent_ns
;
3677 /* Builds the parameter list for the iso_c_binding procedure
3678 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3679 generic version of either the c_f_pointer or c_f_procpointer
3680 functions. The new_proc_sym represents a "resolved" version of the
3681 symbol. The functions are resolved to match the types of their
3682 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3683 something similar to c_f_pointer_i4 if the type of data object fptr
3684 pointed to was a default integer. The actual name of the resolved
3685 procedure symbol is further mangled with the module name, etc., but
3686 the idea holds true. */
3689 build_formal_args (gfc_symbol
*new_proc_sym
,
3690 gfc_symbol
*old_sym
, int add_optional_arg
)
3692 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3693 gfc_namespace
*parent_ns
= NULL
;
3695 parent_ns
= gfc_current_ns
;
3696 /* Create a new namespace, which will be the formal ns (namespace
3697 of the formal args). */
3698 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3699 gfc_current_ns
->proc_name
= new_proc_sym
;
3701 /* Generate the params. */
3702 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3703 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3705 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3706 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3707 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3708 gfc_current_ns
, "fptr");
3710 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3711 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3713 gen_shape_param (&head
, &tail
,
3714 (const char *) new_proc_sym
->module
,
3715 gfc_current_ns
, "shape");
3718 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3720 /* c_associated has one required arg and one optional; both
3722 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3723 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3724 if (add_optional_arg
)
3726 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3727 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3728 /* The last param is optional so mark it as such. */
3729 tail
->sym
->attr
.optional
= 1;
3733 /* Add the interface (store formal args to new_proc_sym). */
3734 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3736 /* Set up the formal_ns pointer to the one created for the
3737 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3738 new_proc_sym
->formal_ns
= gfc_current_ns
;
3740 gfc_current_ns
= parent_ns
;
3744 /* Generate the given set of C interoperable kind objects, or all
3745 interoperable kinds. This function will only be given kind objects
3746 for valid iso_c_binding defined types because this is verified when
3747 the 'use' statement is parsed. If the user gives an 'only' clause,
3748 the specific kinds are looked up; if they don't exist, an error is
3749 reported. If the user does not give an 'only' clause, all
3750 iso_c_binding symbols are generated. If a list of specific kinds
3751 is given, it must have a NULL in the first empty spot to mark the
3756 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3757 const char *local_name
)
3759 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3760 : c_interop_kinds_table
[s
].name
;
3761 gfc_symtree
*tmp_symtree
= NULL
;
3762 gfc_symbol
*tmp_sym
= NULL
;
3763 gfc_dt_list
**dt_list_ptr
= NULL
;
3764 gfc_component
*tmp_comp
= NULL
;
3765 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3768 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3770 /* Already exists in this scope so don't re-add it.
3771 TODO: we should probably check that it's really the same symbol. */
3772 if (tmp_symtree
!= NULL
)
3775 /* Create the sym tree in the current ns. */
3776 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3778 tmp_sym
= tmp_symtree
->n
.sym
;
3780 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3783 /* Say what module this symbol belongs to. */
3784 tmp_sym
->module
= gfc_get_string (mod_name
);
3785 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3786 tmp_sym
->intmod_sym_id
= s
;
3791 #define NAMED_INTCST(a,b,c) case a :
3792 #define NAMED_REALCST(a,b,c) case a :
3793 #define NAMED_CMPXCST(a,b,c) case a :
3794 #define NAMED_LOGCST(a,b,c) case a :
3795 #define NAMED_CHARKNDCST(a,b,c) case a :
3796 #include "iso-c-binding.def"
3798 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3800 /* Initialize an integer constant expression node. */
3801 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3802 tmp_sym
->ts
.type
= BT_INTEGER
;
3803 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3805 /* Mark this type as a C interoperable one. */
3806 tmp_sym
->ts
.is_c_interop
= 1;
3807 tmp_sym
->ts
.is_iso_c
= 1;
3808 tmp_sym
->value
->ts
.is_c_interop
= 1;
3809 tmp_sym
->value
->ts
.is_iso_c
= 1;
3810 tmp_sym
->attr
.is_c_interop
= 1;
3812 /* Tell what f90 type this c interop kind is valid. */
3813 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3815 /* Say it's from the iso_c_binding module. */
3816 tmp_sym
->attr
.is_iso_c
= 1;
3818 /* Make it use associated. */
3819 tmp_sym
->attr
.use_assoc
= 1;
3823 #define NAMED_CHARCST(a,b,c) case a :
3824 #include "iso-c-binding.def"
3826 /* Initialize an integer constant expression node for the
3827 length of the character. */
3828 tmp_sym
->value
= gfc_get_expr ();
3829 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3830 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3831 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3832 tmp_sym
->value
->where
= gfc_current_locus
;
3833 tmp_sym
->value
->ts
.is_c_interop
= 1;
3834 tmp_sym
->value
->ts
.is_iso_c
= 1;
3835 tmp_sym
->value
->value
.character
.length
= 1;
3836 tmp_sym
->value
->value
.character
.string
= gfc_getmem (2);
3837 tmp_sym
->value
->value
.character
.string
[0]
3838 = (char) c_interop_kinds_table
[s
].value
;
3839 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3840 tmp_sym
->ts
.cl
= gfc_get_charlen ();
3841 tmp_sym
->ts
.cl
->length
= gfc_int_expr (1);
3843 /* May not need this in both attr and ts, but do need in
3844 attr for writing module file. */
3845 tmp_sym
->attr
.is_c_interop
= 1;
3847 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3848 tmp_sym
->ts
.type
= BT_CHARACTER
;
3850 /* Need to set it to the C_CHAR kind. */
3851 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3853 /* Mark this type as a C interoperable one. */
3854 tmp_sym
->ts
.is_c_interop
= 1;
3855 tmp_sym
->ts
.is_iso_c
= 1;
3857 /* Tell what f90 type this c interop kind is valid. */
3858 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3860 /* Say it's from the iso_c_binding module. */
3861 tmp_sym
->attr
.is_iso_c
= 1;
3863 /* Make it use associated. */
3864 tmp_sym
->attr
.use_assoc
= 1;
3867 case ISOCBINDING_PTR
:
3868 case ISOCBINDING_FUNPTR
:
3870 /* Initialize an integer constant expression node. */
3871 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3872 tmp_sym
->ts
.is_c_interop
= 1;
3873 tmp_sym
->attr
.is_c_interop
= 1;
3874 tmp_sym
->attr
.is_iso_c
= 1;
3875 tmp_sym
->ts
.is_iso_c
= 1;
3876 tmp_sym
->ts
.type
= BT_DERIVED
;
3878 /* A derived type must have the bind attribute to be
3879 interoperable (J3/04-007, Section 15.2.3), even though
3880 the binding label is not used. */
3881 tmp_sym
->attr
.is_bind_c
= 1;
3883 tmp_sym
->attr
.referenced
= 1;
3885 tmp_sym
->ts
.derived
= tmp_sym
;
3887 /* Add the symbol created for the derived type to the current ns. */
3888 dt_list_ptr
= &(gfc_derived_types
);
3889 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3890 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3892 /* There is already at least one derived type in the list, so append
3893 the one we're currently building for c_ptr or c_funptr. */
3894 if (*dt_list_ptr
!= NULL
)
3895 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3896 (*dt_list_ptr
) = gfc_get_dt_list ();
3897 (*dt_list_ptr
)->derived
= tmp_sym
;
3898 (*dt_list_ptr
)->next
= NULL
;
3900 /* Set up the component of the derived type, which will be
3901 an integer with kind equal to c_ptr_size. Mangle the name of
3902 the field for the c_address to prevent the curious user from
3903 trying to access it from Fortran. */
3904 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3905 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3906 if (tmp_comp
== NULL
)
3907 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3908 "create component for c_address");
3910 tmp_comp
->ts
.type
= BT_INTEGER
;
3912 /* Set this because the module will need to read/write this field. */
3913 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3915 /* The kinds for c_ptr and c_funptr are the same. */
3916 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3917 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3919 tmp_comp
->pointer
= 0;
3920 tmp_comp
->dimension
= 0;
3922 /* Mark the component as C interoperable. */
3923 tmp_comp
->ts
.is_c_interop
= 1;
3925 /* Make it use associated (iso_c_binding module). */
3926 tmp_sym
->attr
.use_assoc
= 1;
3929 case ISOCBINDING_NULL_PTR
:
3930 case ISOCBINDING_NULL_FUNPTR
:
3931 gen_special_c_interop_ptr (s
, name
, mod_name
);
3934 case ISOCBINDING_F_POINTER
:
3935 case ISOCBINDING_ASSOCIATED
:
3936 case ISOCBINDING_LOC
:
3937 case ISOCBINDING_FUNLOC
:
3938 case ISOCBINDING_F_PROCPOINTER
:
3940 tmp_sym
->attr
.proc
= PROC_MODULE
;
3942 /* Use the procedure's name as it is in the iso_c_binding module for
3943 setting the binding label in case the user renamed the symbol. */
3944 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3945 c_interop_kinds_table
[s
].name
);
3946 tmp_sym
->attr
.is_iso_c
= 1;
3947 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3948 tmp_sym
->attr
.subroutine
= 1;
3951 /* TODO! This needs to be finished more for the expr of the
3952 function or something!
3953 This may not need to be here, because trying to do c_loc
3955 if (s
== ISOCBINDING_ASSOCIATED
)
3957 tmp_sym
->attr
.function
= 1;
3958 tmp_sym
->ts
.type
= BT_LOGICAL
;
3959 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3960 tmp_sym
->result
= tmp_sym
;
3964 /* Here, we're taking the simple approach. We're defining
3965 c_loc as an external identifier so the compiler will put
3966 what we expect on the stack for the address we want the
3968 tmp_sym
->ts
.type
= BT_DERIVED
;
3969 if (s
== ISOCBINDING_LOC
)
3970 tmp_sym
->ts
.derived
=
3971 get_iso_c_binding_dt (ISOCBINDING_PTR
);
3973 tmp_sym
->ts
.derived
=
3974 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3976 if (tmp_sym
->ts
.derived
== NULL
)
3978 /* Create the necessary derived type so we can continue
3979 processing the file. */
3980 generate_isocbinding_symbol
3981 (mod_name
, s
== ISOCBINDING_FUNLOC
3982 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
3983 (const char *)(s
== ISOCBINDING_FUNLOC
3984 ? "_gfortran_iso_c_binding_c_funptr"
3985 : "_gfortran_iso_c_binding_c_ptr"));
3986 tmp_sym
->ts
.derived
=
3987 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
3988 ? ISOCBINDING_FUNPTR
3992 /* The function result is itself (no result clause). */
3993 tmp_sym
->result
= tmp_sym
;
3994 tmp_sym
->attr
.external
= 1;
3995 tmp_sym
->attr
.use_assoc
= 0;
3996 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
3997 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4001 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4002 tmp_sym
->attr
.contained
= 0;
4004 /* Try using this builder routine, with the new and old symbols
4005 both being the generic iso_c proc sym being created. This
4006 will create the formal args (and the new namespace for them).
4007 Don't build an arg list for c_loc because we're going to treat
4008 c_loc as an external procedure. */
4009 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4010 /* The 1 says to add any optional args, if applicable. */
4011 build_formal_args (tmp_sym
, tmp_sym
, 1);
4013 /* Set this after setting up the symbol, to prevent error messages. */
4014 tmp_sym
->attr
.use_assoc
= 1;
4016 /* This symbol will not be referenced directly. It will be
4017 resolved to the implementation for the given f90 kind. */
4018 tmp_sym
->attr
.referenced
= 0;
4028 /* Creates a new symbol based off of an old iso_c symbol, with a new
4029 binding label. This function can be used to create a new,
4030 resolved, version of a procedure symbol for c_f_pointer or
4031 c_f_procpointer that is based on the generic symbols. A new
4032 parameter list is created for the new symbol using
4033 build_formal_args(). The add_optional_flag specifies whether the
4034 to add the optional SHAPE argument. The new symbol is
4038 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4039 char *new_binding_label
, int add_optional_arg
)
4041 gfc_symtree
*new_symtree
= NULL
;
4043 /* See if we have a symbol by that name already available, looking
4044 through any parent namespaces. */
4045 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4046 if (new_symtree
!= NULL
)
4047 /* Return the existing symbol. */
4048 return new_symtree
->n
.sym
;
4050 /* Create the symtree/symbol, with attempted host association. */
4051 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4052 if (new_symtree
== NULL
)
4053 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4054 "symtree for '%s'", new_name
);
4056 /* Now fill in the fields of the resolved symbol with the old sym. */
4057 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4058 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4059 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4060 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4061 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4062 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4063 /* Build the formal arg list. */
4064 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4066 gfc_commit_symbol (new_symtree
->n
.sym
);
4068 return new_symtree
->n
.sym
;