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
);
438 if (!attr
->if_source
)
439 conf (external
, dimension
); /* See Fortran 95's R504. */
441 conf (external
, intrinsic
);
442 conf (entry
, intrinsic
);
444 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
446 conf (external
, subroutine
);
447 conf (external
, function
);
450 conf (allocatable
, pointer
);
451 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
452 conf_std (allocatable
, function
, GFC_STD_F2003
);
453 conf_std (allocatable
, result
, GFC_STD_F2003
);
454 conf (elemental
, recursive
);
456 conf (in_common
, dummy
);
457 conf (in_common
, allocatable
);
458 conf (in_common
, result
);
460 conf (dummy
, result
);
462 conf (in_equivalence
, use_assoc
);
463 conf (in_equivalence
, dummy
);
464 conf (in_equivalence
, target
);
465 conf (in_equivalence
, pointer
);
466 conf (in_equivalence
, function
);
467 conf (in_equivalence
, result
);
468 conf (in_equivalence
, entry
);
469 conf (in_equivalence
, allocatable
);
470 conf (in_equivalence
, threadprivate
);
472 conf (in_namelist
, pointer
);
473 conf (in_namelist
, allocatable
);
475 conf (entry
, result
);
477 conf (function
, subroutine
);
479 if (!function
&& !subroutine
)
480 conf (is_bind_c
, dummy
);
482 conf (is_bind_c
, cray_pointer
);
483 conf (is_bind_c
, cray_pointee
);
484 conf (is_bind_c
, allocatable
);
485 conf (is_bind_c
, elemental
);
487 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
488 Parameter conflict caught below. Also, value cannot be specified
489 for a dummy procedure. */
491 /* Cray pointer/pointee conflicts. */
492 conf (cray_pointer
, cray_pointee
);
493 conf (cray_pointer
, dimension
);
494 conf (cray_pointer
, pointer
);
495 conf (cray_pointer
, target
);
496 conf (cray_pointer
, allocatable
);
497 conf (cray_pointer
, external
);
498 conf (cray_pointer
, intrinsic
);
499 conf (cray_pointer
, in_namelist
);
500 conf (cray_pointer
, function
);
501 conf (cray_pointer
, subroutine
);
502 conf (cray_pointer
, entry
);
504 conf (cray_pointee
, allocatable
);
505 conf (cray_pointee
, intent
);
506 conf (cray_pointee
, optional
);
507 conf (cray_pointee
, dummy
);
508 conf (cray_pointee
, target
);
509 conf (cray_pointee
, intrinsic
);
510 conf (cray_pointee
, pointer
);
511 conf (cray_pointee
, entry
);
512 conf (cray_pointee
, in_common
);
513 conf (cray_pointee
, in_equivalence
);
514 conf (cray_pointee
, threadprivate
);
517 conf (data
, function
);
519 conf (data
, allocatable
);
520 conf (data
, use_assoc
);
522 conf (value
, pointer
)
523 conf (value
, allocatable
)
524 conf (value
, subroutine
)
525 conf (value
, function
)
526 conf (value
, volatile_
)
527 conf (value
, dimension
)
528 conf (value
, external
)
531 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
534 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
538 conf (protected, intrinsic
)
539 conf (protected, external
)
540 conf (protected, in_common
)
542 conf (volatile_
, intrinsic
)
543 conf (volatile_
, external
)
545 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
552 conf (procedure
, allocatable
)
553 conf (procedure
, dimension
)
554 conf (procedure
, intrinsic
)
555 conf (procedure
, protected)
556 conf (procedure
, target
)
557 conf (procedure
, value
)
558 conf (procedure
, volatile_
)
559 conf (procedure
, entry
)
560 /* TODO: Implement procedure pointers. */
561 if (attr
->procedure
&& attr
->pointer
)
563 gfc_error ("Fortran 2003: Procedure pointers at %L are "
564 "not yet implemented in gfortran", where
);
568 a1
= gfc_code2string (flavors
, attr
->flavor
);
570 if (attr
->in_namelist
571 && attr
->flavor
!= FL_VARIABLE
572 && attr
->flavor
!= FL_PROCEDURE
573 && attr
->flavor
!= FL_UNKNOWN
)
579 switch (attr
->flavor
)
599 conf2 (threadprivate
);
601 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
603 a2
= attr
->access
== ACCESS_PUBLIC
? public : private;
604 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
611 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
624 if (attr
->subroutine
)
633 conf2 (threadprivate
);
638 case PROC_ST_FUNCTION
:
650 conf2 (threadprivate
);
670 conf2 (threadprivate
);
672 if (attr
->intent
!= INTENT_UNKNOWN
)
694 conf2 (threadprivate
);
707 gfc_error ("%s attribute conflicts with %s attribute at %L",
710 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
711 a1
, a2
, name
, where
);
718 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
719 "with %s attribute at %L", a1
, a2
,
724 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
725 "with %s attribute in '%s' at %L",
726 a1
, a2
, name
, where
);
735 /* Mark a symbol as referenced. */
738 gfc_set_sym_referenced (gfc_symbol
*sym
)
741 if (sym
->attr
.referenced
)
744 sym
->attr
.referenced
= 1;
746 /* Remember which order dummy variables are accessed in. */
748 sym
->dummy_order
= next_dummy_order
++;
752 /* Common subroutine called by attribute changing subroutines in order
753 to prevent them from changing a symbol that has been
754 use-associated. Returns zero if it is OK to change the symbol,
758 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
761 if (attr
->use_assoc
== 0)
765 where
= &gfc_current_locus
;
768 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
771 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
778 /* Generate an error because of a duplicate attribute. */
781 duplicate_attr (const char *attr
, locus
*where
)
785 where
= &gfc_current_locus
;
787 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
791 /* Called from decl.c (attr_decl1) to check attributes, when declared
795 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
798 if (check_used (attr
, NULL
, where
))
801 return check_conflict (attr
, NULL
, where
);
805 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
808 if (check_used (attr
, NULL
, where
))
811 if (attr
->allocatable
)
813 duplicate_attr ("ALLOCATABLE", where
);
817 attr
->allocatable
= 1;
818 return check_conflict (attr
, NULL
, where
);
823 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
826 if (check_used (attr
, name
, where
))
831 duplicate_attr ("DIMENSION", where
);
836 return check_conflict (attr
, name
, where
);
841 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
844 if (check_used (attr
, NULL
, where
))
849 duplicate_attr ("EXTERNAL", where
);
855 return check_conflict (attr
, NULL
, where
);
860 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
863 if (check_used (attr
, NULL
, where
))
868 duplicate_attr ("INTRINSIC", where
);
874 return check_conflict (attr
, NULL
, where
);
879 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
882 if (check_used (attr
, NULL
, where
))
887 duplicate_attr ("OPTIONAL", where
);
892 return check_conflict (attr
, NULL
, where
);
897 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
900 if (check_used (attr
, NULL
, where
))
904 return check_conflict (attr
, NULL
, where
);
909 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
912 if (check_used (attr
, NULL
, where
))
915 attr
->cray_pointer
= 1;
916 return check_conflict (attr
, NULL
, where
);
921 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
924 if (check_used (attr
, NULL
, where
))
927 if (attr
->cray_pointee
)
929 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
930 " statements", where
);
934 attr
->cray_pointee
= 1;
935 return check_conflict (attr
, NULL
, where
);
940 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
942 if (check_used (attr
, name
, where
))
947 if (gfc_notify_std (GFC_STD_LEGACY
,
948 "Duplicate PROTECTED attribute specified at %L",
955 return check_conflict (attr
, name
, where
);
960 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
963 if (check_used (attr
, name
, where
))
967 return check_conflict (attr
, name
, where
);
972 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
975 if (check_used (attr
, name
, where
))
981 ("SAVE attribute at %L cannot be specified in a PURE procedure",
986 if (attr
->save
== SAVE_EXPLICIT
)
988 if (gfc_notify_std (GFC_STD_LEGACY
,
989 "Duplicate SAVE attribute specified at %L",
995 attr
->save
= SAVE_EXPLICIT
;
996 return check_conflict (attr
, name
, where
);
1001 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1004 if (check_used (attr
, name
, where
))
1009 if (gfc_notify_std (GFC_STD_LEGACY
,
1010 "Duplicate VALUE attribute specified at %L",
1017 return check_conflict (attr
, name
, where
);
1022 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1024 /* No check_used needed as 11.2.1 of the F2003 standard allows
1025 that the local identifier made accessible by a use statement can be
1026 given a VOLATILE attribute. */
1028 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1029 if (gfc_notify_std (GFC_STD_LEGACY
,
1030 "Duplicate VOLATILE attribute specified at %L", where
)
1034 attr
->volatile_
= 1;
1035 attr
->volatile_ns
= gfc_current_ns
;
1036 return check_conflict (attr
, name
, where
);
1041 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1044 if (check_used (attr
, name
, where
))
1047 if (attr
->threadprivate
)
1049 duplicate_attr ("THREADPRIVATE", where
);
1053 attr
->threadprivate
= 1;
1054 return check_conflict (attr
, name
, where
);
1059 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1062 if (check_used (attr
, NULL
, where
))
1067 duplicate_attr ("TARGET", where
);
1072 return check_conflict (attr
, NULL
, where
);
1077 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1080 if (check_used (attr
, name
, where
))
1083 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1085 return check_conflict (attr
, name
, where
);
1090 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1093 if (check_used (attr
, name
, where
))
1096 /* Duplicate attribute already checked for. */
1097 attr
->in_common
= 1;
1098 if (check_conflict (attr
, name
, where
) == FAILURE
)
1101 if (attr
->flavor
== FL_VARIABLE
)
1104 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1109 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1112 /* Duplicate attribute already checked for. */
1113 attr
->in_equivalence
= 1;
1114 if (check_conflict (attr
, name
, where
) == FAILURE
)
1117 if (attr
->flavor
== FL_VARIABLE
)
1120 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1125 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1128 if (check_used (attr
, name
, where
))
1132 return check_conflict (attr
, name
, where
);
1137 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1140 attr
->in_namelist
= 1;
1141 return check_conflict (attr
, name
, where
);
1146 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1149 if (check_used (attr
, name
, where
))
1153 return check_conflict (attr
, name
, where
);
1158 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1161 if (check_used (attr
, NULL
, where
))
1164 if (attr
->elemental
)
1166 duplicate_attr ("ELEMENTAL", where
);
1170 attr
->elemental
= 1;
1171 return check_conflict (attr
, NULL
, where
);
1176 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1179 if (check_used (attr
, NULL
, where
))
1184 duplicate_attr ("PURE", where
);
1189 return check_conflict (attr
, NULL
, where
);
1194 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1197 if (check_used (attr
, NULL
, where
))
1200 if (attr
->recursive
)
1202 duplicate_attr ("RECURSIVE", where
);
1206 attr
->recursive
= 1;
1207 return check_conflict (attr
, NULL
, where
);
1212 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1215 if (check_used (attr
, name
, where
))
1220 duplicate_attr ("ENTRY", where
);
1225 return check_conflict (attr
, name
, where
);
1230 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1233 if (attr
->flavor
!= FL_PROCEDURE
1234 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1238 return check_conflict (attr
, name
, where
);
1243 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1246 if (attr
->flavor
!= FL_PROCEDURE
1247 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1250 attr
->subroutine
= 1;
1251 return check_conflict (attr
, name
, where
);
1256 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1259 if (attr
->flavor
!= FL_PROCEDURE
1260 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1264 return check_conflict (attr
, name
, where
);
1269 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1272 if (check_used (attr
, NULL
, where
))
1275 if (attr
->flavor
!= FL_PROCEDURE
1276 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1279 if (attr
->procedure
)
1281 duplicate_attr ("PROCEDURE", where
);
1285 attr
->procedure
= 1;
1287 return check_conflict (attr
, NULL
, where
);
1291 /* Flavors are special because some flavors are not what Fortran
1292 considers attributes and can be reaffirmed multiple times. */
1295 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1299 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1300 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1301 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1304 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1307 if (attr
->flavor
!= FL_UNKNOWN
)
1310 where
= &gfc_current_locus
;
1313 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1314 gfc_code2string (flavors
, attr
->flavor
), name
,
1315 gfc_code2string (flavors
, f
), where
);
1317 gfc_error ("%s attribute conflicts with %s attribute at %L",
1318 gfc_code2string (flavors
, attr
->flavor
),
1319 gfc_code2string (flavors
, f
), where
);
1326 return check_conflict (attr
, name
, where
);
1331 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1332 const char *name
, locus
*where
)
1335 if (check_used (attr
, name
, where
))
1338 if (attr
->flavor
!= FL_PROCEDURE
1339 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1343 where
= &gfc_current_locus
;
1345 if (attr
->proc
!= PROC_UNKNOWN
)
1347 gfc_error ("%s procedure at %L is already declared as %s procedure",
1348 gfc_code2string (procedures
, t
), where
,
1349 gfc_code2string (procedures
, attr
->proc
));
1356 /* Statement functions are always scalar and functions. */
1357 if (t
== PROC_ST_FUNCTION
1358 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1359 || attr
->dimension
))
1362 return check_conflict (attr
, name
, where
);
1367 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1370 if (check_used (attr
, NULL
, where
))
1373 if (attr
->intent
== INTENT_UNKNOWN
)
1375 attr
->intent
= intent
;
1376 return check_conflict (attr
, NULL
, where
);
1380 where
= &gfc_current_locus
;
1382 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1383 gfc_intent_string (attr
->intent
),
1384 gfc_intent_string (intent
), where
);
1390 /* No checks for use-association in public and private statements. */
1393 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1394 const char *name
, locus
*where
)
1397 if (attr
->access
== ACCESS_UNKNOWN
)
1399 attr
->access
= access
;
1400 return check_conflict (attr
, name
, where
);
1404 where
= &gfc_current_locus
;
1405 gfc_error ("ACCESS specification at %L was already specified", where
);
1411 /* Set the is_bind_c field for the given symbol_attribute. */
1414 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1415 int is_proc_lang_bind_spec
)
1418 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1419 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1420 "variables or common blocks", where
);
1421 else if (attr
->is_bind_c
)
1422 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1424 attr
->is_bind_c
= 1;
1427 where
= &gfc_current_locus
;
1429 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1433 return check_conflict (attr
, name
, where
);
1438 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1439 gfc_formal_arglist
* formal
, locus
*where
)
1442 if (check_used (&sym
->attr
, sym
->name
, where
))
1446 where
= &gfc_current_locus
;
1448 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1449 && sym
->attr
.if_source
!= IFSRC_DECL
)
1451 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1456 sym
->formal
= formal
;
1457 sym
->attr
.if_source
= source
;
1463 /* Add a type to a symbol. */
1466 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1471 where
= &gfc_current_locus
;
1473 if (sym
->ts
.type
!= BT_UNKNOWN
)
1475 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1476 if (!(sym
->ts
.type
== ts
->type
1477 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1478 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1481 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1484 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1485 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1489 flavor
= sym
->attr
.flavor
;
1491 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1492 || flavor
== FL_LABEL
1493 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1494 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1496 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1505 /* Clears all attributes. */
1508 gfc_clear_attr (symbol_attribute
*attr
)
1510 memset (attr
, 0, sizeof (symbol_attribute
));
1514 /* Check for missing attributes in the new symbol. Currently does
1515 nothing, but it's not clear that it is unnecessary yet. */
1518 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1519 locus
*where ATTRIBUTE_UNUSED
)
1526 /* Copy an attribute to a symbol attribute, bit by bit. Some
1527 attributes have a lot of side-effects but cannot be present given
1528 where we are called from, so we ignore some bits. */
1531 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1533 int is_proc_lang_bind_spec
;
1535 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1538 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1540 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1542 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1544 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1546 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1548 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1550 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1552 if (src
->threadprivate
1553 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1555 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1557 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1559 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1564 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1567 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1570 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1572 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1574 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1577 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1579 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1581 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1583 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1586 if (src
->flavor
!= FL_UNKNOWN
1587 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1590 if (src
->intent
!= INTENT_UNKNOWN
1591 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1594 if (src
->access
!= ACCESS_UNKNOWN
1595 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1598 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1601 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1603 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1606 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1608 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1612 if (src
->is_c_interop
)
1613 dest
->is_c_interop
= 1;
1617 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1619 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1629 /************** Component name management ************/
1631 /* Component names of a derived type form their own little namespaces
1632 that are separate from all other spaces. The space is composed of
1633 a singly linked list of gfc_component structures whose head is
1634 located in the parent symbol. */
1637 /* Add a component name to a symbol. The call fails if the name is
1638 already present. On success, the component pointer is modified to
1639 point to the additional component structure. */
1642 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1643 gfc_component
**component
)
1645 gfc_component
*p
, *tail
;
1649 for (p
= sym
->components
; p
; p
= p
->next
)
1651 if (strcmp (p
->name
, name
) == 0)
1653 gfc_error ("Component '%s' at %C already declared at %L",
1661 /* Allocate a new component. */
1662 p
= gfc_get_component ();
1665 sym
->components
= p
;
1669 p
->name
= gfc_get_string (name
);
1670 p
->loc
= gfc_current_locus
;
1677 /* Recursive function to switch derived types of all symbol in a
1681 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1689 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1690 sym
->ts
.derived
= to
;
1692 switch_types (st
->left
, from
, to
);
1693 switch_types (st
->right
, from
, to
);
1697 /* This subroutine is called when a derived type is used in order to
1698 make the final determination about which version to use. The
1699 standard requires that a type be defined before it is 'used', but
1700 such types can appear in IMPLICIT statements before the actual
1701 definition. 'Using' in this context means declaring a variable to
1702 be that type or using the type constructor.
1704 If a type is used and the components haven't been defined, then we
1705 have to have a derived type in a parent unit. We find the node in
1706 the other namespace and point the symtree node in this namespace to
1707 that node. Further reference to this name point to the correct
1708 node. If we can't find the node in a parent namespace, then we have
1711 This subroutine takes a pointer to a symbol node and returns a
1712 pointer to the translated node or NULL for an error. Usually there
1713 is no translation and we return the node we were passed. */
1716 gfc_use_derived (gfc_symbol
*sym
)
1723 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1724 return sym
; /* Already defined. */
1726 if (sym
->ns
->parent
== NULL
)
1729 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1731 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1735 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1738 /* Get rid of symbol sym, translating all references to s. */
1739 for (i
= 0; i
< GFC_LETTERS
; i
++)
1741 t
= &sym
->ns
->default_type
[i
];
1742 if (t
->derived
== sym
)
1746 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1751 /* Unlink from list of modified symbols. */
1752 gfc_commit_symbol (sym
);
1754 switch_types (sym
->ns
->sym_root
, sym
, s
);
1756 /* TODO: Also have to replace sym -> s in other lists like
1757 namelists, common lists and interface lists. */
1758 gfc_free_symbol (sym
);
1763 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1769 /* Given a derived type node and a component name, try to locate the
1770 component structure. Returns the NULL pointer if the component is
1771 not found or the components are private. */
1774 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1781 sym
= gfc_use_derived (sym
);
1786 for (p
= sym
->components
; p
; p
= p
->next
)
1787 if (strcmp (p
->name
, name
) == 0)
1791 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1795 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1796 || p
->access
== ACCESS_PRIVATE
))
1798 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1808 /* Given a symbol, free all of the component structures and everything
1812 free_components (gfc_component
*p
)
1820 gfc_free_array_spec (p
->as
);
1821 gfc_free_expr (p
->initializer
);
1828 /* Set component attributes from a standard symbol attribute structure. */
1831 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1834 c
->dimension
= attr
->dimension
;
1835 c
->pointer
= attr
->pointer
;
1836 c
->allocatable
= attr
->allocatable
;
1837 c
->access
= attr
->access
;
1841 /* Get a standard symbol attribute structure given the component
1845 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1848 gfc_clear_attr (attr
);
1849 attr
->dimension
= c
->dimension
;
1850 attr
->pointer
= c
->pointer
;
1851 attr
->allocatable
= c
->allocatable
;
1852 attr
->access
= c
->access
;
1856 /******************** Statement label management ********************/
1858 /* Comparison function for statement labels, used for managing the
1862 compare_st_labels (void *a1
, void *b1
)
1864 int a
= ((gfc_st_label
*) a1
)->value
;
1865 int b
= ((gfc_st_label
*) b1
)->value
;
1871 /* Free a single gfc_st_label structure, making sure the tree is not
1872 messed up. This function is called only when some parse error
1876 gfc_free_st_label (gfc_st_label
*label
)
1882 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1884 if (label
->format
!= NULL
)
1885 gfc_free_expr (label
->format
);
1891 /* Free a whole tree of gfc_st_label structures. */
1894 free_st_labels (gfc_st_label
*label
)
1900 free_st_labels (label
->left
);
1901 free_st_labels (label
->right
);
1903 if (label
->format
!= NULL
)
1904 gfc_free_expr (label
->format
);
1909 /* Given a label number, search for and return a pointer to the label
1910 structure, creating it if it does not exist. */
1913 gfc_get_st_label (int labelno
)
1917 /* First see if the label is already in this namespace. */
1918 lp
= gfc_current_ns
->st_labels
;
1921 if (lp
->value
== labelno
)
1924 if (lp
->value
< labelno
)
1930 lp
= gfc_getmem (sizeof (gfc_st_label
));
1932 lp
->value
= labelno
;
1933 lp
->defined
= ST_LABEL_UNKNOWN
;
1934 lp
->referenced
= ST_LABEL_UNKNOWN
;
1936 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1942 /* Called when a statement with a statement label is about to be
1943 accepted. We add the label to the list of the current namespace,
1944 making sure it hasn't been defined previously and referenced
1948 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1952 labelno
= lp
->value
;
1954 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1955 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1956 &lp
->where
, label_locus
);
1959 lp
->where
= *label_locus
;
1963 case ST_LABEL_FORMAT
:
1964 if (lp
->referenced
== ST_LABEL_TARGET
)
1965 gfc_error ("Label %d at %C already referenced as branch target",
1968 lp
->defined
= ST_LABEL_FORMAT
;
1972 case ST_LABEL_TARGET
:
1973 if (lp
->referenced
== ST_LABEL_FORMAT
)
1974 gfc_error ("Label %d at %C already referenced as a format label",
1977 lp
->defined
= ST_LABEL_TARGET
;
1982 lp
->defined
= ST_LABEL_BAD_TARGET
;
1983 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1989 /* Reference a label. Given a label and its type, see if that
1990 reference is consistent with what is known about that label,
1991 updating the unknown state. Returns FAILURE if something goes
1995 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1997 gfc_sl_type label_type
;
2004 labelno
= lp
->value
;
2006 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2007 label_type
= lp
->defined
;
2010 label_type
= lp
->referenced
;
2011 lp
->where
= gfc_current_locus
;
2014 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2016 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2021 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2022 && type
== ST_LABEL_FORMAT
)
2024 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2029 lp
->referenced
= type
;
2037 /*******A helper function for creating new expressions*************/
2041 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2044 lval
= gfc_get_expr ();
2045 lval
->expr_type
= EXPR_VARIABLE
;
2046 lval
->where
= sym
->declared_at
;
2048 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2050 /* It will always be a full array. */
2051 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2054 lval
->ref
= gfc_get_ref ();
2055 lval
->ref
->type
= REF_ARRAY
;
2056 lval
->ref
->u
.ar
.type
= AR_FULL
;
2057 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2058 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2059 lval
->ref
->u
.ar
.as
= sym
->as
;
2066 /************** Symbol table management subroutines ****************/
2068 /* Basic details: Fortran 95 requires a potentially unlimited number
2069 of distinct namespaces when compiling a program unit. This case
2070 occurs during a compilation of internal subprograms because all of
2071 the internal subprograms must be read before we can start
2072 generating code for the host.
2074 Given the tricky nature of the Fortran grammar, we must be able to
2075 undo changes made to a symbol table if the current interpretation
2076 of a statement is found to be incorrect. Whenever a symbol is
2077 looked up, we make a copy of it and link to it. All of these
2078 symbols are kept in a singly linked list so that we can commit or
2079 undo the changes at a later time.
2081 A symtree may point to a symbol node outside of its namespace. In
2082 this case, that symbol has been used as a host associated variable
2083 at some previous time. */
2085 /* Allocate a new namespace structure. Copies the implicit types from
2086 PARENT if PARENT_TYPES is set. */
2089 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2093 gfc_intrinsic_op in
;
2096 ns
= gfc_getmem (sizeof (gfc_namespace
));
2097 ns
->sym_root
= NULL
;
2098 ns
->uop_root
= NULL
;
2099 ns
->default_access
= ACCESS_UNKNOWN
;
2100 ns
->parent
= parent
;
2102 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2103 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2105 /* Initialize default implicit types. */
2106 for (i
= 'a'; i
<= 'z'; i
++)
2108 ns
->set_flag
[i
- 'a'] = 0;
2109 ts
= &ns
->default_type
[i
- 'a'];
2111 if (parent_types
&& ns
->parent
!= NULL
)
2113 /* Copy parent settings. */
2114 *ts
= ns
->parent
->default_type
[i
- 'a'];
2118 if (gfc_option
.flag_implicit_none
!= 0)
2124 if ('i' <= i
&& i
<= 'n')
2126 ts
->type
= BT_INTEGER
;
2127 ts
->kind
= gfc_default_integer_kind
;
2132 ts
->kind
= gfc_default_real_kind
;
2142 /* Comparison function for symtree nodes. */
2145 compare_symtree (void *_st1
, void *_st2
)
2147 gfc_symtree
*st1
, *st2
;
2149 st1
= (gfc_symtree
*) _st1
;
2150 st2
= (gfc_symtree
*) _st2
;
2152 return strcmp (st1
->name
, st2
->name
);
2156 /* Allocate a new symtree node and associate it with the new symbol. */
2159 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2163 st
= gfc_getmem (sizeof (gfc_symtree
));
2164 st
->name
= gfc_get_string (name
);
2166 gfc_insert_bbt (root
, st
, compare_symtree
);
2171 /* Delete a symbol from the tree. Does not free the symbol itself! */
2174 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2176 gfc_symtree st
, *st0
;
2178 st0
= gfc_find_symtree (*root
, name
);
2180 st
.name
= gfc_get_string (name
);
2181 gfc_delete_bbt (root
, &st
, compare_symtree
);
2187 /* Given a root symtree node and a name, try to find the symbol within
2188 the namespace. Returns NULL if the symbol is not found. */
2191 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2197 c
= strcmp (name
, st
->name
);
2201 st
= (c
< 0) ? st
->left
: st
->right
;
2208 /* Return a symtree node with a name that is guaranteed to be unique
2209 within the namespace and corresponds to an illegal fortran name. */
2212 gfc_get_unique_symtree (gfc_namespace
*ns
)
2214 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2215 static int serial
= 0;
2217 sprintf (name
, "@%d", serial
++);
2218 return gfc_new_symtree (&ns
->sym_root
, name
);
2222 /* Given a name find a user operator node, creating it if it doesn't
2223 exist. These are much simpler than symbols because they can't be
2224 ambiguous with one another. */
2227 gfc_get_uop (const char *name
)
2232 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2236 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2238 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2239 uop
->name
= gfc_get_string (name
);
2240 uop
->access
= ACCESS_UNKNOWN
;
2241 uop
->ns
= gfc_current_ns
;
2247 /* Given a name find the user operator node. Returns NULL if it does
2251 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2256 ns
= gfc_current_ns
;
2258 st
= gfc_find_symtree (ns
->uop_root
, name
);
2259 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2263 /* Remove a gfc_symbol structure and everything it points to. */
2266 gfc_free_symbol (gfc_symbol
*sym
)
2272 gfc_free_array_spec (sym
->as
);
2274 free_components (sym
->components
);
2276 gfc_free_expr (sym
->value
);
2278 gfc_free_namelist (sym
->namelist
);
2280 gfc_free_namespace (sym
->formal_ns
);
2282 if (!sym
->attr
.generic_copy
)
2283 gfc_free_interface (sym
->generic
);
2285 gfc_free_formal_arglist (sym
->formal
);
2291 /* Allocate and initialize a new symbol node. */
2294 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2298 p
= gfc_getmem (sizeof (gfc_symbol
));
2300 gfc_clear_ts (&p
->ts
);
2301 gfc_clear_attr (&p
->attr
);
2304 p
->declared_at
= gfc_current_locus
;
2306 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2307 gfc_internal_error ("new_symbol(): Symbol name too long");
2309 p
->name
= gfc_get_string (name
);
2311 /* Make sure flags for symbol being C bound are clear initially. */
2312 p
->attr
.is_bind_c
= 0;
2313 p
->attr
.is_iso_c
= 0;
2314 /* Make sure the binding label field has a Nul char to start. */
2315 p
->binding_label
[0] = '\0';
2317 /* Clear the ptrs we may need. */
2318 p
->common_block
= NULL
;
2324 /* Generate an error if a symbol is ambiguous. */
2327 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2330 if (st
->n
.sym
->module
)
2331 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2332 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2334 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2335 "from current program unit", name
, st
->n
.sym
->name
);
2339 /* Search for a symtree starting in the current namespace, resorting to
2340 any parent namespaces if requested by a nonzero parent_flag.
2341 Returns nonzero if the name is ambiguous. */
2344 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2345 gfc_symtree
**result
)
2350 ns
= gfc_current_ns
;
2354 st
= gfc_find_symtree (ns
->sym_root
, name
);
2358 /* Ambiguous generic interfaces are permitted, as long
2359 as the specific interfaces are different. */
2360 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2362 ambiguous_symbol (name
, st
);
2381 /* Same, but returns the symbol instead. */
2384 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2385 gfc_symbol
**result
)
2390 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2395 *result
= st
->n
.sym
;
2401 /* Save symbol with the information necessary to back it out. */
2404 save_symbol_data (gfc_symbol
*sym
)
2407 if (sym
->new || sym
->old_symbol
!= NULL
)
2410 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2411 *(sym
->old_symbol
) = *sym
;
2413 sym
->tlink
= changed_syms
;
2418 /* Given a name, find a symbol, or create it if it does not exist yet
2419 in the current namespace. If the symbol is found we make sure that
2422 The integer return code indicates
2424 1 The symbol name was ambiguous
2425 2 The name meant to be established was already host associated.
2427 So if the return value is nonzero, then an error was issued. */
2430 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2435 /* This doesn't usually happen during resolution. */
2437 ns
= gfc_current_ns
;
2439 /* Try to find the symbol in ns. */
2440 st
= gfc_find_symtree (ns
->sym_root
, name
);
2444 /* If not there, create a new symbol. */
2445 p
= gfc_new_symbol (name
, ns
);
2447 /* Add to the list of tentative symbols. */
2448 p
->old_symbol
= NULL
;
2449 p
->tlink
= changed_syms
;
2454 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2461 /* Make sure the existing symbol is OK. Ambiguous
2462 generic interfaces are permitted, as long as the
2463 specific interfaces are different. */
2464 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2466 ambiguous_symbol (name
, st
);
2472 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2474 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2475 && (ns
->has_import_set
|| p
->attr
.imported
)))
2477 /* Symbol is from another namespace. */
2478 gfc_error ("Symbol '%s' at %C has already been host associated",
2485 /* Copy in case this symbol is changed. */
2486 save_symbol_data (p
);
2495 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2500 i
= gfc_get_sym_tree (name
, ns
, &st
);
2505 *result
= st
->n
.sym
;
2512 /* Subroutine that searches for a symbol, creating it if it doesn't
2513 exist, but tries to host-associate the symbol if possible. */
2516 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2521 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2524 save_symbol_data (st
->n
.sym
);
2529 if (gfc_current_ns
->parent
!= NULL
)
2531 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2542 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2547 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2552 i
= gfc_get_ha_sym_tree (name
, &st
);
2555 *result
= st
->n
.sym
;
2562 /* Return true if both symbols could refer to the same data object. Does
2563 not take account of aliasing due to equivalence statements. */
2566 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2568 /* Aliasing isn't possible if the symbols have different base types. */
2569 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2572 /* Pointers can point to other pointers, target objects and allocatable
2573 objects. Two allocatable objects cannot share the same storage. */
2574 if (lsym
->attr
.pointer
2575 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2577 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2579 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2586 /* Undoes all the changes made to symbols in the current statement.
2587 This subroutine is made simpler due to the fact that attributes are
2588 never removed once added. */
2591 gfc_undo_symbols (void)
2593 gfc_symbol
*p
, *q
, *old
;
2595 for (p
= changed_syms
; p
; p
= q
)
2601 /* Symbol was new. */
2602 if (p
->attr
.in_common
&& p
->common_block
->head
)
2604 /* If the symbol was added to any common block, it
2605 needs to be removed to stop the resolver looking
2606 for a (possibly) dead symbol. */
2608 if (p
->common_block
->head
== p
)
2609 p
->common_block
->head
= p
->common_next
;
2612 gfc_symbol
*cparent
, *csym
;
2614 cparent
= p
->common_block
->head
;
2615 csym
= cparent
->common_next
;
2620 csym
= csym
->common_next
;
2623 gcc_assert(cparent
->common_next
== p
);
2625 cparent
->common_next
= csym
->common_next
;
2629 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2633 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2635 gfc_free_symbol (p
);
2639 /* Restore previous state of symbol. Just copy simple stuff. */
2641 old
= p
->old_symbol
;
2643 p
->ts
.type
= old
->ts
.type
;
2644 p
->ts
.kind
= old
->ts
.kind
;
2646 p
->attr
= old
->attr
;
2648 if (p
->value
!= old
->value
)
2650 gfc_free_expr (old
->value
);
2654 if (p
->as
!= old
->as
)
2657 gfc_free_array_spec (p
->as
);
2661 p
->generic
= old
->generic
;
2662 p
->component_access
= old
->component_access
;
2664 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2666 gfc_free_namelist (p
->namelist
);
2671 if (p
->namelist_tail
!= old
->namelist_tail
)
2673 gfc_free_namelist (old
->namelist_tail
);
2674 old
->namelist_tail
->next
= NULL
;
2678 p
->namelist_tail
= old
->namelist_tail
;
2680 if (p
->formal
!= old
->formal
)
2682 gfc_free_formal_arglist (p
->formal
);
2683 p
->formal
= old
->formal
;
2686 gfc_free (p
->old_symbol
);
2687 p
->old_symbol
= NULL
;
2691 changed_syms
= NULL
;
2695 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2696 components of old_symbol that might need deallocation are the "allocatables"
2697 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2698 namelist_tail. In case these differ between old_symbol and sym, it's just
2699 because sym->namelist has gotten a few more items. */
2702 free_old_symbol (gfc_symbol
*sym
)
2705 if (sym
->old_symbol
== NULL
)
2708 if (sym
->old_symbol
->as
!= sym
->as
)
2709 gfc_free_array_spec (sym
->old_symbol
->as
);
2711 if (sym
->old_symbol
->value
!= sym
->value
)
2712 gfc_free_expr (sym
->old_symbol
->value
);
2714 if (sym
->old_symbol
->formal
!= sym
->formal
)
2715 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2717 gfc_free (sym
->old_symbol
);
2718 sym
->old_symbol
= NULL
;
2722 /* Makes the changes made in the current statement permanent-- gets
2723 rid of undo information. */
2726 gfc_commit_symbols (void)
2730 for (p
= changed_syms
; p
; p
= q
)
2736 free_old_symbol (p
);
2738 changed_syms
= NULL
;
2742 /* Makes the changes made in one symbol permanent -- gets rid of undo
2746 gfc_commit_symbol (gfc_symbol
*sym
)
2750 if (changed_syms
== sym
)
2751 changed_syms
= sym
->tlink
;
2754 for (p
= changed_syms
; p
; p
= p
->tlink
)
2755 if (p
->tlink
== sym
)
2757 p
->tlink
= sym
->tlink
;
2766 free_old_symbol (sym
);
2770 /* Recursive function that deletes an entire tree and all the common
2771 head structures it points to. */
2774 free_common_tree (gfc_symtree
* common_tree
)
2776 if (common_tree
== NULL
)
2779 free_common_tree (common_tree
->left
);
2780 free_common_tree (common_tree
->right
);
2782 gfc_free (common_tree
);
2786 /* Recursive function that deletes an entire tree and all the user
2787 operator nodes that it contains. */
2790 free_uop_tree (gfc_symtree
*uop_tree
)
2793 if (uop_tree
== NULL
)
2796 free_uop_tree (uop_tree
->left
);
2797 free_uop_tree (uop_tree
->right
);
2799 gfc_free_interface (uop_tree
->n
.uop
->operator);
2801 gfc_free (uop_tree
->n
.uop
);
2802 gfc_free (uop_tree
);
2806 /* Recursive function that deletes an entire tree and all the symbols
2807 that it contains. */
2810 free_sym_tree (gfc_symtree
*sym_tree
)
2815 if (sym_tree
== NULL
)
2818 free_sym_tree (sym_tree
->left
);
2819 free_sym_tree (sym_tree
->right
);
2821 sym
= sym_tree
->n
.sym
;
2825 gfc_internal_error ("free_sym_tree(): Negative refs");
2827 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2829 /* As formal_ns contains a reference to sym, delete formal_ns just
2830 before the deletion of sym. */
2831 ns
= sym
->formal_ns
;
2832 sym
->formal_ns
= NULL
;
2833 gfc_free_namespace (ns
);
2835 else if (sym
->refs
== 0)
2837 /* Go ahead and delete the symbol. */
2838 gfc_free_symbol (sym
);
2841 gfc_free (sym_tree
);
2845 /* Free the derived type list. */
2848 gfc_free_dt_list (void)
2850 gfc_dt_list
*dt
, *n
;
2852 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2858 gfc_derived_types
= NULL
;
2862 /* Free the gfc_equiv_info's. */
2865 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2869 gfc_free_equiv_infos (s
->next
);
2874 /* Free the gfc_equiv_lists. */
2877 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2881 gfc_free_equiv_lists (l
->next
);
2882 gfc_free_equiv_infos (l
->equiv
);
2887 /* Free a namespace structure and everything below it. Interface
2888 lists associated with intrinsic operators are not freed. These are
2889 taken care of when a specific name is freed. */
2892 gfc_free_namespace (gfc_namespace
*ns
)
2894 gfc_charlen
*cl
, *cl2
;
2895 gfc_namespace
*p
, *q
;
2904 gcc_assert (ns
->refs
== 0);
2906 gfc_free_statements (ns
->code
);
2908 free_sym_tree (ns
->sym_root
);
2909 free_uop_tree (ns
->uop_root
);
2910 free_common_tree (ns
->common_root
);
2912 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2915 gfc_free_expr (cl
->length
);
2919 free_st_labels (ns
->st_labels
);
2921 gfc_free_equiv (ns
->equiv
);
2922 gfc_free_equiv_lists (ns
->equiv_lists
);
2924 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2925 gfc_free_interface (ns
->operator[i
]);
2927 gfc_free_data (ns
->data
);
2931 /* Recursively free any contained namespaces. */
2936 gfc_free_namespace (q
);
2942 gfc_symbol_init_2 (void)
2945 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2950 gfc_symbol_done_2 (void)
2953 gfc_free_namespace (gfc_current_ns
);
2954 gfc_current_ns
= NULL
;
2955 gfc_free_dt_list ();
2959 /* Clear mark bits from symbol nodes associated with a symtree node. */
2962 clear_sym_mark (gfc_symtree
*st
)
2965 st
->n
.sym
->mark
= 0;
2969 /* Recursively traverse the symtree nodes. */
2972 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2977 gfc_traverse_symtree (st
->left
, func
);
2979 gfc_traverse_symtree (st
->right
, func
);
2983 /* Recursive namespace traversal function. */
2986 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2992 traverse_ns (st
->left
, func
);
2994 if (st
->n
.sym
->mark
== 0)
2995 (*func
) (st
->n
.sym
);
2996 st
->n
.sym
->mark
= 1;
2998 traverse_ns (st
->right
, func
);
3002 /* Call a given function for all symbols in the namespace. We take
3003 care that each gfc_symbol node is called exactly once. */
3006 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3009 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3011 traverse_ns (ns
->sym_root
, func
);
3015 /* Return TRUE when name is the name of an intrinsic type. */
3018 gfc_is_intrinsic_typename (const char *name
)
3020 if (strcmp (name
, "integer") == 0
3021 || strcmp (name
, "real") == 0
3022 || strcmp (name
, "character") == 0
3023 || strcmp (name
, "logical") == 0
3024 || strcmp (name
, "complex") == 0
3025 || strcmp (name
, "doubleprecision") == 0
3026 || strcmp (name
, "doublecomplex") == 0)
3033 /* Return TRUE if the symbol is an automatic variable. */
3036 gfc_is_var_automatic (gfc_symbol
*sym
)
3038 /* Pointer and allocatable variables are never automatic. */
3039 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3041 /* Check for arrays with non-constant size. */
3042 if (sym
->attr
.dimension
&& sym
->as
3043 && !gfc_is_compile_time_shape (sym
->as
))
3045 /* Check for non-constant length character variables. */
3046 if (sym
->ts
.type
== BT_CHARACTER
3048 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
3053 /* Given a symbol, mark it as SAVEd if it is allowed. */
3056 save_symbol (gfc_symbol
*sym
)
3059 if (sym
->attr
.use_assoc
)
3062 if (sym
->attr
.in_common
3064 || sym
->attr
.flavor
!= FL_VARIABLE
)
3066 /* Automatic objects are not saved. */
3067 if (gfc_is_var_automatic (sym
))
3069 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3073 /* Mark those symbols which can be SAVEd as such. */
3076 gfc_save_all (gfc_namespace
*ns
)
3079 gfc_traverse_ns (ns
, save_symbol
);
3084 /* Make sure that no changes to symbols are pending. */
3087 gfc_symbol_state(void) {
3089 if (changed_syms
!= NULL
)
3090 gfc_internal_error("Symbol changes still pending!");
3095 /************** Global symbol handling ************/
3098 /* Search a tree for the global symbol. */
3101 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3110 c
= strcmp (name
, symbol
->name
);
3114 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3121 /* Compare two global symbols. Used for managing the BB tree. */
3124 gsym_compare (void *_s1
, void *_s2
)
3126 gfc_gsymbol
*s1
, *s2
;
3128 s1
= (gfc_gsymbol
*) _s1
;
3129 s2
= (gfc_gsymbol
*) _s2
;
3130 return strcmp (s1
->name
, s2
->name
);
3134 /* Get a global symbol, creating it if it doesn't exist. */
3137 gfc_get_gsymbol (const char *name
)
3141 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3145 s
= gfc_getmem (sizeof (gfc_gsymbol
));
3146 s
->type
= GSYM_UNKNOWN
;
3147 s
->name
= gfc_get_string (name
);
3149 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3156 get_iso_c_binding_dt (int sym_id
)
3158 gfc_dt_list
*dt_list
;
3160 dt_list
= gfc_derived_types
;
3162 /* Loop through the derived types in the name list, searching for
3163 the desired symbol from iso_c_binding. Search the parent namespaces
3164 if necessary and requested to (parent_flag). */
3165 while (dt_list
!= NULL
)
3167 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3168 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3169 return dt_list
->derived
;
3171 dt_list
= dt_list
->next
;
3178 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3179 with C. This is necessary for any derived type that is BIND(C) and for
3180 derived types that are parameters to functions that are BIND(C). All
3181 fields of the derived type are required to be interoperable, and are tested
3182 for such. If an error occurs, the errors are reported here, allowing for
3183 multiple errors to be handled for a single derived type. */
3186 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3188 gfc_component
*curr_comp
= NULL
;
3189 try is_c_interop
= FAILURE
;
3190 try retval
= SUCCESS
;
3192 if (derived_sym
== NULL
)
3193 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3194 "unexpectedly NULL");
3196 /* If we've already looked at this derived symbol, do not look at it again
3197 so we don't repeat warnings/errors. */
3198 if (derived_sym
->ts
.is_c_interop
)
3201 /* The derived type must have the BIND attribute to be interoperable
3202 J3/04-007, Section 15.2.3. */
3203 if (derived_sym
->attr
.is_bind_c
!= 1)
3205 derived_sym
->ts
.is_c_interop
= 0;
3206 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3207 "attribute to be C interoperable", derived_sym
->name
,
3208 &(derived_sym
->declared_at
));
3212 curr_comp
= derived_sym
->components
;
3214 /* TODO: is this really an error? */
3215 if (curr_comp
== NULL
)
3217 gfc_error ("Derived type '%s' at %L is empty",
3218 derived_sym
->name
, &(derived_sym
->declared_at
));
3222 /* Initialize the derived type as being C interoperable.
3223 If we find an error in the components, this will be set false. */
3224 derived_sym
->ts
.is_c_interop
= 1;
3226 /* Loop through the list of components to verify that the kind of
3227 each is a C interoperable type. */
3230 /* The components cannot be pointers (fortran sense).
3231 J3/04-007, Section 15.2.3, C1505. */
3232 if (curr_comp
->pointer
!= 0)
3234 gfc_error ("Component '%s' at %L cannot have the "
3235 "POINTER attribute because it is a member "
3236 "of the BIND(C) derived type '%s' at %L",
3237 curr_comp
->name
, &(curr_comp
->loc
),
3238 derived_sym
->name
, &(derived_sym
->declared_at
));
3242 /* The components cannot be allocatable.
3243 J3/04-007, Section 15.2.3, C1505. */
3244 if (curr_comp
->allocatable
!= 0)
3246 gfc_error ("Component '%s' at %L cannot have the "
3247 "ALLOCATABLE attribute because it is a member "
3248 "of the BIND(C) derived type '%s' at %L",
3249 curr_comp
->name
, &(curr_comp
->loc
),
3250 derived_sym
->name
, &(derived_sym
->declared_at
));
3254 /* BIND(C) derived types must have interoperable components. */
3255 if (curr_comp
->ts
.type
== BT_DERIVED
3256 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3257 && curr_comp
->ts
.derived
!= derived_sym
)
3259 /* This should be allowed; the draft says a derived-type can not
3260 have type parameters if it is has the BIND attribute. Type
3261 parameters seem to be for making parameterized derived types.
3262 There's no need to verify the type if it is c_ptr/c_funptr. */
3263 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3267 /* Grab the typespec for the given component and test the kind. */
3268 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3271 if (is_c_interop
!= SUCCESS
)
3273 /* Report warning and continue since not fatal. The
3274 draft does specify a constraint that requires all fields
3275 to interoperate, but if the user says real(4), etc., it
3276 may interoperate with *something* in C, but the compiler
3277 most likely won't know exactly what. Further, it may not
3278 interoperate with the same data type(s) in C if the user
3279 recompiles with different flags (e.g., -m32 and -m64 on
3280 x86_64 and using integer(4) to claim interop with a
3282 if (derived_sym
->attr
.is_bind_c
== 1)
3283 /* If the derived type is bind(c), all fields must be
3285 gfc_warning ("Component '%s' in derived type '%s' at %L "
3286 "may not be C interoperable, even though "
3287 "derived type '%s' is BIND(C)",
3288 curr_comp
->name
, derived_sym
->name
,
3289 &(curr_comp
->loc
), derived_sym
->name
);
3291 /* If derived type is param to bind(c) routine, or to one
3292 of the iso_c_binding procs, it must be interoperable, so
3293 all fields must interop too. */
3294 gfc_warning ("Component '%s' in derived type '%s' at %L "
3295 "may not be C interoperable",
3296 curr_comp
->name
, derived_sym
->name
,
3301 curr_comp
= curr_comp
->next
;
3302 } while (curr_comp
!= NULL
);
3305 /* Make sure we don't have conflicts with the attributes. */
3306 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3308 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3309 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3310 &(derived_sym
->declared_at
));
3314 if (derived_sym
->attr
.sequence
!= 0)
3316 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3317 "attribute because it is BIND(C)", derived_sym
->name
,
3318 &(derived_sym
->declared_at
));
3322 /* Mark the derived type as not being C interoperable if we found an
3323 error. If there were only warnings, proceed with the assumption
3324 it's interoperable. */
3325 if (retval
== FAILURE
)
3326 derived_sym
->ts
.is_c_interop
= 0;
3332 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3335 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3336 const char *module_name
)
3338 gfc_symtree
*tmp_symtree
;
3339 gfc_symbol
*tmp_sym
;
3341 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3343 if (tmp_symtree
!= NULL
)
3344 tmp_sym
= tmp_symtree
->n
.sym
;
3348 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3349 "create symbol for %s", ptr_name
);
3352 /* Set up the symbol's important fields. Save attr required so we can
3353 initialize the ptr to NULL. */
3354 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3355 tmp_sym
->ts
.is_c_interop
= 1;
3356 tmp_sym
->attr
.is_c_interop
= 1;
3357 tmp_sym
->ts
.is_iso_c
= 1;
3358 tmp_sym
->ts
.type
= BT_DERIVED
;
3360 /* The c_ptr and c_funptr derived types will provide the
3361 definition for c_null_ptr and c_null_funptr, respectively. */
3362 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3363 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3365 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3366 if (tmp_sym
->ts
.derived
== NULL
)
3368 /* This can occur if the user forgot to declare c_ptr or
3369 c_funptr and they're trying to use one of the procedures
3370 that has arg(s) of the missing type. In this case, a
3371 regular version of the thing should have been put in the
3373 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3374 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3375 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3376 ? "_gfortran_iso_c_binding_c_ptr"
3377 : "_gfortran_iso_c_binding_c_funptr"));
3379 tmp_sym
->ts
.derived
=
3380 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3381 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3384 /* Module name is some mangled version of iso_c_binding. */
3385 tmp_sym
->module
= gfc_get_string (module_name
);
3387 /* Say it's from the iso_c_binding module. */
3388 tmp_sym
->attr
.is_iso_c
= 1;
3390 tmp_sym
->attr
.use_assoc
= 1;
3391 tmp_sym
->attr
.is_bind_c
= 1;
3392 /* Set the binding_label. */
3393 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3395 /* Set the c_address field of c_null_ptr and c_null_funptr to
3396 the value of NULL. */
3397 tmp_sym
->value
= gfc_get_expr ();
3398 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3399 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3400 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3401 /* Create a constructor with no expr, that way we can recognize if the user
3402 tries to call the structure constructor for one of the iso_c_binding
3403 derived types during resolution (resolve_structure_cons). */
3404 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3405 /* Must declare c_null_ptr and c_null_funptr as having the
3406 PARAMETER attribute so they can be used in init expressions. */
3407 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3413 /* Add a formal argument, gfc_formal_arglist, to the
3414 end of the given list of arguments. Set the reference to the
3415 provided symbol, param_sym, in the argument. */
3418 add_formal_arg (gfc_formal_arglist
**head
,
3419 gfc_formal_arglist
**tail
,
3420 gfc_formal_arglist
*formal_arg
,
3421 gfc_symbol
*param_sym
)
3423 /* Put in list, either as first arg or at the tail (curr arg). */
3425 *head
= *tail
= formal_arg
;
3428 (*tail
)->next
= formal_arg
;
3429 (*tail
) = formal_arg
;
3432 (*tail
)->sym
= param_sym
;
3433 (*tail
)->next
= NULL
;
3439 /* Generates a symbol representing the CPTR argument to an
3440 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3441 CPTR and add it to the provided argument list. */
3444 gen_cptr_param (gfc_formal_arglist
**head
,
3445 gfc_formal_arglist
**tail
,
3446 const char *module_name
,
3447 gfc_namespace
*ns
, const char *c_ptr_name
,
3450 gfc_symbol
*param_sym
= NULL
;
3451 gfc_symbol
*c_ptr_sym
= NULL
;
3452 gfc_symtree
*param_symtree
= NULL
;
3453 gfc_formal_arglist
*formal_arg
= NULL
;
3454 const char *c_ptr_in
;
3455 const char *c_ptr_type
= NULL
;
3457 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3458 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3460 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3462 if(c_ptr_name
== NULL
)
3463 c_ptr_in
= "gfc_cptr__";
3465 c_ptr_in
= c_ptr_name
;
3466 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3467 if (param_symtree
!= NULL
)
3468 param_sym
= param_symtree
->n
.sym
;
3470 gfc_internal_error ("gen_cptr_param(): Unable to "
3471 "create symbol for %s", c_ptr_in
);
3473 /* Set up the appropriate fields for the new c_ptr param sym. */
3475 param_sym
->attr
.flavor
= FL_DERIVED
;
3476 param_sym
->ts
.type
= BT_DERIVED
;
3477 param_sym
->attr
.intent
= INTENT_IN
;
3478 param_sym
->attr
.dummy
= 1;
3480 /* This will pass the ptr to the iso_c routines as a (void *). */
3481 param_sym
->attr
.value
= 1;
3482 param_sym
->attr
.use_assoc
= 1;
3484 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3486 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3487 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3489 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3490 if (c_ptr_sym
== NULL
)
3492 /* This can happen if the user did not define c_ptr but they are
3493 trying to use one of the iso_c_binding functions that need it. */
3494 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3495 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3496 (const char *)c_ptr_type
);
3498 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3499 (const char *)c_ptr_type
);
3501 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3504 param_sym
->ts
.derived
= c_ptr_sym
;
3505 param_sym
->module
= gfc_get_string (module_name
);
3507 /* Make new formal arg. */
3508 formal_arg
= gfc_get_formal_arglist ();
3509 /* Add arg to list of formal args (the CPTR arg). */
3510 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3514 /* Generates a symbol representing the FPTR argument to an
3515 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3516 FPTR and add it to the provided argument list. */
3519 gen_fptr_param (gfc_formal_arglist
**head
,
3520 gfc_formal_arglist
**tail
,
3521 const char *module_name
,
3522 gfc_namespace
*ns
, const char *f_ptr_name
)
3524 gfc_symbol
*param_sym
= NULL
;
3525 gfc_symtree
*param_symtree
= NULL
;
3526 gfc_formal_arglist
*formal_arg
= NULL
;
3527 const char *f_ptr_out
= "gfc_fptr__";
3529 if (f_ptr_name
!= NULL
)
3530 f_ptr_out
= f_ptr_name
;
3532 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3533 if (param_symtree
!= NULL
)
3534 param_sym
= param_symtree
->n
.sym
;
3536 gfc_internal_error ("generateFPtrParam(): Unable to "
3537 "create symbol for %s", f_ptr_out
);
3539 /* Set up the necessary fields for the fptr output param sym. */
3541 param_sym
->attr
.pointer
= 1;
3542 param_sym
->attr
.dummy
= 1;
3543 param_sym
->attr
.use_assoc
= 1;
3545 /* ISO C Binding type to allow any pointer type as actual param. */
3546 param_sym
->ts
.type
= BT_VOID
;
3547 param_sym
->module
= gfc_get_string (module_name
);
3550 formal_arg
= gfc_get_formal_arglist ();
3551 /* Add arg to list of formal args. */
3552 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3556 /* Generates a symbol representing the optional SHAPE argument for the
3557 iso_c_binding c_f_pointer() procedure. Also, create a
3558 gfc_formal_arglist for the SHAPE and add it to the provided
3562 gen_shape_param (gfc_formal_arglist
**head
,
3563 gfc_formal_arglist
**tail
,
3564 const char *module_name
,
3565 gfc_namespace
*ns
, const char *shape_param_name
)
3567 gfc_symbol
*param_sym
= NULL
;
3568 gfc_symtree
*param_symtree
= NULL
;
3569 gfc_formal_arglist
*formal_arg
= NULL
;
3570 const char *shape_param
= "gfc_shape_array__";
3573 if (shape_param_name
!= NULL
)
3574 shape_param
= shape_param_name
;
3576 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3577 if (param_symtree
!= NULL
)
3578 param_sym
= param_symtree
->n
.sym
;
3580 gfc_internal_error ("generateShapeParam(): Unable to "
3581 "create symbol for %s", shape_param
);
3583 /* Set up the necessary fields for the shape input param sym. */
3585 param_sym
->attr
.dummy
= 1;
3586 param_sym
->attr
.use_assoc
= 1;
3588 /* Integer array, rank 1, describing the shape of the object. Make it's
3589 type BT_VOID initially so we can accept any type/kind combination of
3590 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3591 of BT_INTEGER type. */
3592 param_sym
->ts
.type
= BT_VOID
;
3594 /* Initialize the kind to default integer. However, it will be overridden
3595 during resolution to match the kind of the SHAPE parameter given as
3596 the actual argument (to allow for any valid integer kind). */
3597 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3598 param_sym
->as
= gfc_get_array_spec ();
3600 /* Clear out the dimension info for the array. */
3601 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3603 param_sym
->as
->lower
[i
] = NULL
;
3604 param_sym
->as
->upper
[i
] = NULL
;
3606 param_sym
->as
->rank
= 1;
3607 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3609 /* The extent is unknown until we get it. The length give us
3610 the rank the incoming pointer. */
3611 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3613 /* The arg is also optional; it is required iff the second arg
3614 (fptr) is to an array, otherwise, it's ignored. */
3615 param_sym
->attr
.optional
= 1;
3616 param_sym
->attr
.intent
= INTENT_IN
;
3617 param_sym
->attr
.dimension
= 1;
3618 param_sym
->module
= gfc_get_string (module_name
);
3621 formal_arg
= gfc_get_formal_arglist ();
3622 /* Add arg to list of formal args. */
3623 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3626 /* Add a procedure interface to the given symbol (i.e., store a
3627 reference to the list of formal arguments). */
3630 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3631 gfc_formal_arglist
*formal
)
3634 sym
->formal
= formal
;
3635 sym
->attr
.if_source
= source
;
3638 /* Copy the formal args from an existing symbol, src, into a new
3639 symbol, dest. New formal args are created, and the description of
3640 each arg is set according to the existing ones. This function is
3641 used when creating procedure declaration variables from a procedure
3642 declaration statement (see match_proc_decl()) to create the formal
3643 args based on the args of a given named interface. */
3646 copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3648 gfc_formal_arglist
*head
= NULL
;
3649 gfc_formal_arglist
*tail
= NULL
;
3650 gfc_formal_arglist
*formal_arg
= NULL
;
3651 gfc_formal_arglist
*curr_arg
= NULL
;
3652 gfc_formal_arglist
*formal_prev
= NULL
;
3653 /* Save current namespace so we can change it for formal args. */
3654 gfc_namespace
*parent_ns
= gfc_current_ns
;
3656 /* Create a new namespace, which will be the formal ns (namespace
3657 of the formal args). */
3658 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3659 gfc_current_ns
->proc_name
= dest
;
3661 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3663 formal_arg
= gfc_get_formal_arglist ();
3664 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3666 /* May need to copy more info for the symbol. */
3667 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3668 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3669 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
3671 /* If this isn't the first arg, set up the next ptr. For the
3672 last arg built, the formal_arg->next will never get set to
3673 anything other than NULL. */
3674 if (formal_prev
!= NULL
)
3675 formal_prev
->next
= formal_arg
;
3677 formal_arg
->next
= NULL
;
3679 formal_prev
= formal_arg
;
3681 /* Add arg to list of formal args. */
3682 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3685 /* Add the interface to the symbol. */
3686 add_proc_interface (dest
, IFSRC_DECL
, head
);
3688 /* Store the formal namespace information. */
3689 if (dest
->formal
!= NULL
)
3690 /* The current ns should be that for the dest proc. */
3691 dest
->formal_ns
= gfc_current_ns
;
3692 /* Restore the current namespace to what it was on entry. */
3693 gfc_current_ns
= parent_ns
;
3696 /* Builds the parameter list for the iso_c_binding procedure
3697 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3698 generic version of either the c_f_pointer or c_f_procpointer
3699 functions. The new_proc_sym represents a "resolved" version of the
3700 symbol. The functions are resolved to match the types of their
3701 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3702 something similar to c_f_pointer_i4 if the type of data object fptr
3703 pointed to was a default integer. The actual name of the resolved
3704 procedure symbol is further mangled with the module name, etc., but
3705 the idea holds true. */
3708 build_formal_args (gfc_symbol
*new_proc_sym
,
3709 gfc_symbol
*old_sym
, int add_optional_arg
)
3711 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3712 gfc_namespace
*parent_ns
= NULL
;
3714 parent_ns
= gfc_current_ns
;
3715 /* Create a new namespace, which will be the formal ns (namespace
3716 of the formal args). */
3717 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3718 gfc_current_ns
->proc_name
= new_proc_sym
;
3720 /* Generate the params. */
3721 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3722 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3724 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3725 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3726 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3727 gfc_current_ns
, "fptr");
3729 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3730 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3732 gen_shape_param (&head
, &tail
,
3733 (const char *) new_proc_sym
->module
,
3734 gfc_current_ns
, "shape");
3737 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3739 /* c_associated has one required arg and one optional; both
3741 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3742 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3743 if (add_optional_arg
)
3745 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3746 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3747 /* The last param is optional so mark it as such. */
3748 tail
->sym
->attr
.optional
= 1;
3752 /* Add the interface (store formal args to new_proc_sym). */
3753 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3755 /* Set up the formal_ns pointer to the one created for the
3756 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3757 new_proc_sym
->formal_ns
= gfc_current_ns
;
3759 gfc_current_ns
= parent_ns
;
3763 std_for_isocbinding_symbol (int id
)
3767 #define NAMED_INTCST(a,b,c,d) \
3770 #include "iso-c-binding.def"
3773 return GFC_STD_F2003
;
3777 /* Generate the given set of C interoperable kind objects, or all
3778 interoperable kinds. This function will only be given kind objects
3779 for valid iso_c_binding defined types because this is verified when
3780 the 'use' statement is parsed. If the user gives an 'only' clause,
3781 the specific kinds are looked up; if they don't exist, an error is
3782 reported. If the user does not give an 'only' clause, all
3783 iso_c_binding symbols are generated. If a list of specific kinds
3784 is given, it must have a NULL in the first empty spot to mark the
3789 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3790 const char *local_name
)
3792 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3793 : c_interop_kinds_table
[s
].name
;
3794 gfc_symtree
*tmp_symtree
= NULL
;
3795 gfc_symbol
*tmp_sym
= NULL
;
3796 gfc_dt_list
**dt_list_ptr
= NULL
;
3797 gfc_component
*tmp_comp
= NULL
;
3798 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3801 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == FAILURE
)
3803 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3805 /* Already exists in this scope so don't re-add it.
3806 TODO: we should probably check that it's really the same symbol. */
3807 if (tmp_symtree
!= NULL
)
3810 /* Create the sym tree in the current ns. */
3811 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3813 tmp_sym
= tmp_symtree
->n
.sym
;
3815 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3818 /* Say what module this symbol belongs to. */
3819 tmp_sym
->module
= gfc_get_string (mod_name
);
3820 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3821 tmp_sym
->intmod_sym_id
= s
;
3826 #define NAMED_INTCST(a,b,c,d) case a :
3827 #define NAMED_REALCST(a,b,c) case a :
3828 #define NAMED_CMPXCST(a,b,c) case a :
3829 #define NAMED_LOGCST(a,b,c) case a :
3830 #define NAMED_CHARKNDCST(a,b,c) case a :
3831 #include "iso-c-binding.def"
3833 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3835 /* Initialize an integer constant expression node. */
3836 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3837 tmp_sym
->ts
.type
= BT_INTEGER
;
3838 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3840 /* Mark this type as a C interoperable one. */
3841 tmp_sym
->ts
.is_c_interop
= 1;
3842 tmp_sym
->ts
.is_iso_c
= 1;
3843 tmp_sym
->value
->ts
.is_c_interop
= 1;
3844 tmp_sym
->value
->ts
.is_iso_c
= 1;
3845 tmp_sym
->attr
.is_c_interop
= 1;
3847 /* Tell what f90 type this c interop kind is valid. */
3848 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3850 /* Say it's from the iso_c_binding module. */
3851 tmp_sym
->attr
.is_iso_c
= 1;
3853 /* Make it use associated. */
3854 tmp_sym
->attr
.use_assoc
= 1;
3858 #define NAMED_CHARCST(a,b,c) case a :
3859 #include "iso-c-binding.def"
3861 /* Initialize an integer constant expression node for the
3862 length of the character. */
3863 tmp_sym
->value
= gfc_get_expr ();
3864 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3865 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3866 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3867 tmp_sym
->value
->where
= gfc_current_locus
;
3868 tmp_sym
->value
->ts
.is_c_interop
= 1;
3869 tmp_sym
->value
->ts
.is_iso_c
= 1;
3870 tmp_sym
->value
->value
.character
.length
= 1;
3871 tmp_sym
->value
->value
.character
.string
= gfc_get_wide_string (2);
3872 tmp_sym
->value
->value
.character
.string
[0]
3873 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
3874 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3875 tmp_sym
->ts
.cl
= gfc_get_charlen ();
3876 tmp_sym
->ts
.cl
->length
= gfc_int_expr (1);
3878 /* May not need this in both attr and ts, but do need in
3879 attr for writing module file. */
3880 tmp_sym
->attr
.is_c_interop
= 1;
3882 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3883 tmp_sym
->ts
.type
= BT_CHARACTER
;
3885 /* Need to set it to the C_CHAR kind. */
3886 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3888 /* Mark this type as a C interoperable one. */
3889 tmp_sym
->ts
.is_c_interop
= 1;
3890 tmp_sym
->ts
.is_iso_c
= 1;
3892 /* Tell what f90 type this c interop kind is valid. */
3893 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3895 /* Say it's from the iso_c_binding module. */
3896 tmp_sym
->attr
.is_iso_c
= 1;
3898 /* Make it use associated. */
3899 tmp_sym
->attr
.use_assoc
= 1;
3902 case ISOCBINDING_PTR
:
3903 case ISOCBINDING_FUNPTR
:
3905 /* Initialize an integer constant expression node. */
3906 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3907 tmp_sym
->ts
.is_c_interop
= 1;
3908 tmp_sym
->attr
.is_c_interop
= 1;
3909 tmp_sym
->attr
.is_iso_c
= 1;
3910 tmp_sym
->ts
.is_iso_c
= 1;
3911 tmp_sym
->ts
.type
= BT_DERIVED
;
3913 /* A derived type must have the bind attribute to be
3914 interoperable (J3/04-007, Section 15.2.3), even though
3915 the binding label is not used. */
3916 tmp_sym
->attr
.is_bind_c
= 1;
3918 tmp_sym
->attr
.referenced
= 1;
3920 tmp_sym
->ts
.derived
= tmp_sym
;
3922 /* Add the symbol created for the derived type to the current ns. */
3923 dt_list_ptr
= &(gfc_derived_types
);
3924 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3925 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3927 /* There is already at least one derived type in the list, so append
3928 the one we're currently building for c_ptr or c_funptr. */
3929 if (*dt_list_ptr
!= NULL
)
3930 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3931 (*dt_list_ptr
) = gfc_get_dt_list ();
3932 (*dt_list_ptr
)->derived
= tmp_sym
;
3933 (*dt_list_ptr
)->next
= NULL
;
3935 /* Set up the component of the derived type, which will be
3936 an integer with kind equal to c_ptr_size. Mangle the name of
3937 the field for the c_address to prevent the curious user from
3938 trying to access it from Fortran. */
3939 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3940 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3941 if (tmp_comp
== NULL
)
3942 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3943 "create component for c_address");
3945 tmp_comp
->ts
.type
= BT_INTEGER
;
3947 /* Set this because the module will need to read/write this field. */
3948 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3950 /* The kinds for c_ptr and c_funptr are the same. */
3951 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3952 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3954 tmp_comp
->pointer
= 0;
3955 tmp_comp
->dimension
= 0;
3957 /* Mark the component as C interoperable. */
3958 tmp_comp
->ts
.is_c_interop
= 1;
3960 /* Make it use associated (iso_c_binding module). */
3961 tmp_sym
->attr
.use_assoc
= 1;
3964 case ISOCBINDING_NULL_PTR
:
3965 case ISOCBINDING_NULL_FUNPTR
:
3966 gen_special_c_interop_ptr (s
, name
, mod_name
);
3969 case ISOCBINDING_F_POINTER
:
3970 case ISOCBINDING_ASSOCIATED
:
3971 case ISOCBINDING_LOC
:
3972 case ISOCBINDING_FUNLOC
:
3973 case ISOCBINDING_F_PROCPOINTER
:
3975 tmp_sym
->attr
.proc
= PROC_MODULE
;
3977 /* Use the procedure's name as it is in the iso_c_binding module for
3978 setting the binding label in case the user renamed the symbol. */
3979 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3980 c_interop_kinds_table
[s
].name
);
3981 tmp_sym
->attr
.is_iso_c
= 1;
3982 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3983 tmp_sym
->attr
.subroutine
= 1;
3986 /* TODO! This needs to be finished more for the expr of the
3987 function or something!
3988 This may not need to be here, because trying to do c_loc
3990 if (s
== ISOCBINDING_ASSOCIATED
)
3992 tmp_sym
->attr
.function
= 1;
3993 tmp_sym
->ts
.type
= BT_LOGICAL
;
3994 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3995 tmp_sym
->result
= tmp_sym
;
3999 /* Here, we're taking the simple approach. We're defining
4000 c_loc as an external identifier so the compiler will put
4001 what we expect on the stack for the address we want the
4003 tmp_sym
->ts
.type
= BT_DERIVED
;
4004 if (s
== ISOCBINDING_LOC
)
4005 tmp_sym
->ts
.derived
=
4006 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4008 tmp_sym
->ts
.derived
=
4009 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4011 if (tmp_sym
->ts
.derived
== NULL
)
4013 /* Create the necessary derived type so we can continue
4014 processing the file. */
4015 generate_isocbinding_symbol
4016 (mod_name
, s
== ISOCBINDING_FUNLOC
4017 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4018 (const char *)(s
== ISOCBINDING_FUNLOC
4019 ? "_gfortran_iso_c_binding_c_funptr"
4020 : "_gfortran_iso_c_binding_c_ptr"));
4021 tmp_sym
->ts
.derived
=
4022 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4023 ? ISOCBINDING_FUNPTR
4027 /* The function result is itself (no result clause). */
4028 tmp_sym
->result
= tmp_sym
;
4029 tmp_sym
->attr
.external
= 1;
4030 tmp_sym
->attr
.use_assoc
= 0;
4031 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4032 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4036 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4037 tmp_sym
->attr
.contained
= 0;
4039 /* Try using this builder routine, with the new and old symbols
4040 both being the generic iso_c proc sym being created. This
4041 will create the formal args (and the new namespace for them).
4042 Don't build an arg list for c_loc because we're going to treat
4043 c_loc as an external procedure. */
4044 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4045 /* The 1 says to add any optional args, if applicable. */
4046 build_formal_args (tmp_sym
, tmp_sym
, 1);
4048 /* Set this after setting up the symbol, to prevent error messages. */
4049 tmp_sym
->attr
.use_assoc
= 1;
4051 /* This symbol will not be referenced directly. It will be
4052 resolved to the implementation for the given f90 kind. */
4053 tmp_sym
->attr
.referenced
= 0;
4063 /* Creates a new symbol based off of an old iso_c symbol, with a new
4064 binding label. This function can be used to create a new,
4065 resolved, version of a procedure symbol for c_f_pointer or
4066 c_f_procpointer that is based on the generic symbols. A new
4067 parameter list is created for the new symbol using
4068 build_formal_args(). The add_optional_flag specifies whether the
4069 to add the optional SHAPE argument. The new symbol is
4073 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4074 char *new_binding_label
, int add_optional_arg
)
4076 gfc_symtree
*new_symtree
= NULL
;
4078 /* See if we have a symbol by that name already available, looking
4079 through any parent namespaces. */
4080 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4081 if (new_symtree
!= NULL
)
4082 /* Return the existing symbol. */
4083 return new_symtree
->n
.sym
;
4085 /* Create the symtree/symbol, with attempted host association. */
4086 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4087 if (new_symtree
== NULL
)
4088 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4089 "symtree for '%s'", new_name
);
4091 /* Now fill in the fields of the resolved symbol with the old sym. */
4092 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4093 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4094 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4095 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4096 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4097 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4098 /* Build the formal arg list. */
4099 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4101 gfc_commit_symbol (new_symtree
->n
.sym
);
4103 return new_symtree
->n
.sym
;