1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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)";
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
);
441 if (attr
->if_source
|| attr
->contained
)
443 conf (external
, subroutine
);
444 conf (external
, function
);
447 conf (allocatable
, pointer
);
448 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
449 conf_std (allocatable
, function
, GFC_STD_F2003
);
450 conf_std (allocatable
, result
, GFC_STD_F2003
);
451 conf (elemental
, recursive
);
453 conf (in_common
, dummy
);
454 conf (in_common
, allocatable
);
455 conf (in_common
, result
);
457 conf (dummy
, result
);
459 conf (in_equivalence
, use_assoc
);
460 conf (in_equivalence
, dummy
);
461 conf (in_equivalence
, target
);
462 conf (in_equivalence
, pointer
);
463 conf (in_equivalence
, function
);
464 conf (in_equivalence
, result
);
465 conf (in_equivalence
, entry
);
466 conf (in_equivalence
, allocatable
);
467 conf (in_equivalence
, threadprivate
);
469 conf (in_namelist
, pointer
);
470 conf (in_namelist
, allocatable
);
472 conf (entry
, result
);
474 conf (function
, subroutine
);
476 if (!function
&& !subroutine
)
477 conf (is_bind_c
, dummy
);
479 conf (is_bind_c
, cray_pointer
);
480 conf (is_bind_c
, cray_pointee
);
481 conf (is_bind_c
, allocatable
);
483 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
484 Parameter conflict caught below. Also, value cannot be specified
485 for a dummy procedure. */
487 /* Cray pointer/pointee conflicts. */
488 conf (cray_pointer
, cray_pointee
);
489 conf (cray_pointer
, dimension
);
490 conf (cray_pointer
, pointer
);
491 conf (cray_pointer
, target
);
492 conf (cray_pointer
, allocatable
);
493 conf (cray_pointer
, external
);
494 conf (cray_pointer
, intrinsic
);
495 conf (cray_pointer
, in_namelist
);
496 conf (cray_pointer
, function
);
497 conf (cray_pointer
, subroutine
);
498 conf (cray_pointer
, entry
);
500 conf (cray_pointee
, allocatable
);
501 conf (cray_pointee
, intent
);
502 conf (cray_pointee
, optional
);
503 conf (cray_pointee
, dummy
);
504 conf (cray_pointee
, target
);
505 conf (cray_pointee
, intrinsic
);
506 conf (cray_pointee
, pointer
);
507 conf (cray_pointee
, entry
);
508 conf (cray_pointee
, in_common
);
509 conf (cray_pointee
, in_equivalence
);
510 conf (cray_pointee
, threadprivate
);
513 conf (data
, function
);
515 conf (data
, allocatable
);
516 conf (data
, use_assoc
);
518 conf (value
, pointer
)
519 conf (value
, allocatable
)
520 conf (value
, subroutine
)
521 conf (value
, function
)
522 conf (value
, volatile_
)
523 conf (value
, dimension
)
524 conf (value
, external
)
527 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
530 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
534 conf (protected, intrinsic
)
535 conf (protected, external
)
536 conf (protected, in_common
)
538 conf (volatile_
, intrinsic
)
539 conf (volatile_
, external
)
541 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
548 a1
= gfc_code2string (flavors
, attr
->flavor
);
550 if (attr
->in_namelist
551 && attr
->flavor
!= FL_VARIABLE
552 && attr
->flavor
!= FL_PROCEDURE
553 && attr
->flavor
!= FL_UNKNOWN
)
559 switch (attr
->flavor
)
579 conf2 (threadprivate
);
589 if (attr
->subroutine
)
598 conf2 (threadprivate
);
603 case PROC_ST_FUNCTION
:
615 conf2 (threadprivate
);
635 conf2 (threadprivate
);
637 if (attr
->intent
!= INTENT_UNKNOWN
)
659 conf2 (threadprivate
);
660 /* TODO: hmm, double check this. */
672 gfc_error ("%s attribute conflicts with %s attribute at %L",
675 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
676 a1
, a2
, name
, where
);
683 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
684 "with %s attribute at %L", a1
, a2
,
689 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
690 "with %s attribute in '%s' at %L",
691 a1
, a2
, name
, where
);
700 /* Mark a symbol as referenced. */
703 gfc_set_sym_referenced (gfc_symbol
*sym
)
706 if (sym
->attr
.referenced
)
709 sym
->attr
.referenced
= 1;
711 /* Remember which order dummy variables are accessed in. */
713 sym
->dummy_order
= next_dummy_order
++;
717 /* Common subroutine called by attribute changing subroutines in order
718 to prevent them from changing a symbol that has been
719 use-associated. Returns zero if it is OK to change the symbol,
723 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
726 if (attr
->use_assoc
== 0)
730 where
= &gfc_current_locus
;
733 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
736 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
743 /* Generate an error because of a duplicate attribute. */
746 duplicate_attr (const char *attr
, locus
*where
)
750 where
= &gfc_current_locus
;
752 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
756 /* Called from decl.c (attr_decl1) to check attributes, when declared
760 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
763 if (check_used (attr
, NULL
, where
))
766 return check_conflict (attr
, NULL
, where
);
770 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
773 if (check_used (attr
, NULL
, where
))
776 if (attr
->allocatable
)
778 duplicate_attr ("ALLOCATABLE", where
);
782 attr
->allocatable
= 1;
783 return check_conflict (attr
, NULL
, where
);
788 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
791 if (check_used (attr
, name
, where
))
796 duplicate_attr ("DIMENSION", where
);
801 return check_conflict (attr
, name
, where
);
806 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
809 if (check_used (attr
, NULL
, where
))
814 duplicate_attr ("EXTERNAL", where
);
820 return check_conflict (attr
, NULL
, where
);
825 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
828 if (check_used (attr
, NULL
, where
))
833 duplicate_attr ("INTRINSIC", where
);
839 return check_conflict (attr
, NULL
, where
);
844 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
847 if (check_used (attr
, NULL
, where
))
852 duplicate_attr ("OPTIONAL", where
);
857 return check_conflict (attr
, NULL
, where
);
862 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
865 if (check_used (attr
, NULL
, where
))
869 return check_conflict (attr
, NULL
, where
);
874 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
877 if (check_used (attr
, NULL
, where
))
880 attr
->cray_pointer
= 1;
881 return check_conflict (attr
, NULL
, where
);
886 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
889 if (check_used (attr
, NULL
, where
))
892 if (attr
->cray_pointee
)
894 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
895 " statements", where
);
899 attr
->cray_pointee
= 1;
900 return check_conflict (attr
, NULL
, where
);
905 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
907 if (check_used (attr
, name
, where
))
912 if (gfc_notify_std (GFC_STD_LEGACY
,
913 "Duplicate PROTECTED attribute specified at %L",
920 return check_conflict (attr
, name
, where
);
925 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
928 if (check_used (attr
, name
, where
))
932 return check_conflict (attr
, name
, where
);
937 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
940 if (check_used (attr
, name
, where
))
946 ("SAVE attribute at %L cannot be specified in a PURE procedure",
951 if (attr
->save
== SAVE_EXPLICIT
)
953 if (gfc_notify_std (GFC_STD_LEGACY
,
954 "Duplicate SAVE attribute specified at %L",
960 attr
->save
= SAVE_EXPLICIT
;
961 return check_conflict (attr
, name
, where
);
966 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
969 if (check_used (attr
, name
, where
))
974 if (gfc_notify_std (GFC_STD_LEGACY
,
975 "Duplicate VALUE attribute specified at %L",
982 return check_conflict (attr
, name
, where
);
987 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
989 /* No check_used needed as 11.2.1 of the F2003 standard allows
990 that the local identifier made accessible by a use statement can be
991 given a VOLATILE attribute. */
993 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
994 if (gfc_notify_std (GFC_STD_LEGACY
,
995 "Duplicate VOLATILE attribute specified at %L", where
)
1000 attr
->volatile_ns
= gfc_current_ns
;
1001 return check_conflict (attr
, name
, where
);
1006 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1009 if (check_used (attr
, name
, where
))
1012 if (attr
->threadprivate
)
1014 duplicate_attr ("THREADPRIVATE", where
);
1018 attr
->threadprivate
= 1;
1019 return check_conflict (attr
, name
, where
);
1024 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1027 if (check_used (attr
, NULL
, where
))
1032 duplicate_attr ("TARGET", where
);
1037 return check_conflict (attr
, NULL
, where
);
1042 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1045 if (check_used (attr
, name
, where
))
1048 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1050 return check_conflict (attr
, name
, where
);
1055 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1058 if (check_used (attr
, name
, where
))
1061 /* Duplicate attribute already checked for. */
1062 attr
->in_common
= 1;
1063 if (check_conflict (attr
, name
, where
) == FAILURE
)
1066 if (attr
->flavor
== FL_VARIABLE
)
1069 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1074 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1077 /* Duplicate attribute already checked for. */
1078 attr
->in_equivalence
= 1;
1079 if (check_conflict (attr
, name
, where
) == FAILURE
)
1082 if (attr
->flavor
== FL_VARIABLE
)
1085 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1090 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1093 if (check_used (attr
, name
, where
))
1097 return check_conflict (attr
, name
, where
);
1102 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1105 attr
->in_namelist
= 1;
1106 return check_conflict (attr
, name
, where
);
1111 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1114 if (check_used (attr
, name
, where
))
1118 return check_conflict (attr
, name
, where
);
1123 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1126 if (check_used (attr
, NULL
, where
))
1129 attr
->elemental
= 1;
1130 return check_conflict (attr
, NULL
, where
);
1135 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1138 if (check_used (attr
, NULL
, where
))
1142 return check_conflict (attr
, NULL
, where
);
1147 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1150 if (check_used (attr
, NULL
, where
))
1153 attr
->recursive
= 1;
1154 return check_conflict (attr
, NULL
, where
);
1159 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1162 if (check_used (attr
, name
, where
))
1167 duplicate_attr ("ENTRY", where
);
1172 return check_conflict (attr
, name
, where
);
1177 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1180 if (attr
->flavor
!= FL_PROCEDURE
1181 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1185 return check_conflict (attr
, name
, where
);
1190 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1193 if (attr
->flavor
!= FL_PROCEDURE
1194 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1197 attr
->subroutine
= 1;
1198 return check_conflict (attr
, name
, where
);
1203 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1206 if (attr
->flavor
!= FL_PROCEDURE
1207 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1211 return check_conflict (attr
, name
, where
);
1215 /* Flavors are special because some flavors are not what Fortran
1216 considers attributes and can be reaffirmed multiple times. */
1219 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1223 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1224 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1225 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1228 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1231 if (attr
->flavor
!= FL_UNKNOWN
)
1234 where
= &gfc_current_locus
;
1237 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1238 gfc_code2string (flavors
, attr
->flavor
), name
,
1239 gfc_code2string (flavors
, f
), where
);
1241 gfc_error ("%s attribute conflicts with %s attribute at %L",
1242 gfc_code2string (flavors
, attr
->flavor
),
1243 gfc_code2string (flavors
, f
), where
);
1250 return check_conflict (attr
, name
, where
);
1255 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1256 const char *name
, locus
*where
)
1259 if (check_used (attr
, name
, where
))
1262 if (attr
->flavor
!= FL_PROCEDURE
1263 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1267 where
= &gfc_current_locus
;
1269 if (attr
->proc
!= PROC_UNKNOWN
)
1271 gfc_error ("%s procedure at %L is already declared as %s procedure",
1272 gfc_code2string (procedures
, t
), where
,
1273 gfc_code2string (procedures
, attr
->proc
));
1280 /* Statement functions are always scalar and functions. */
1281 if (t
== PROC_ST_FUNCTION
1282 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1283 || attr
->dimension
))
1286 return check_conflict (attr
, name
, where
);
1291 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1294 if (check_used (attr
, NULL
, where
))
1297 if (attr
->intent
== INTENT_UNKNOWN
)
1299 attr
->intent
= intent
;
1300 return check_conflict (attr
, NULL
, where
);
1304 where
= &gfc_current_locus
;
1306 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1307 gfc_intent_string (attr
->intent
),
1308 gfc_intent_string (intent
), where
);
1314 /* No checks for use-association in public and private statements. */
1317 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1318 const char *name
, locus
*where
)
1321 if (attr
->access
== ACCESS_UNKNOWN
)
1323 attr
->access
= access
;
1324 return check_conflict (attr
, name
, where
);
1328 where
= &gfc_current_locus
;
1329 gfc_error ("ACCESS specification at %L was already specified", where
);
1335 /* Set the is_bind_c field for the given symbol_attribute. */
1338 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1339 int is_proc_lang_bind_spec
)
1342 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1343 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1344 "variables or common blocks", where
);
1345 else if (attr
->is_bind_c
)
1346 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1348 attr
->is_bind_c
= 1;
1351 where
= &gfc_current_locus
;
1353 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1357 return check_conflict (attr
, name
, where
);
1362 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1363 gfc_formal_arglist
* formal
, locus
*where
)
1366 if (check_used (&sym
->attr
, sym
->name
, where
))
1370 where
= &gfc_current_locus
;
1372 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1373 && sym
->attr
.if_source
!= IFSRC_DECL
)
1375 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1380 sym
->formal
= formal
;
1381 sym
->attr
.if_source
= source
;
1387 /* Add a type to a symbol. */
1390 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1395 where
= &gfc_current_locus
;
1397 if (sym
->ts
.type
!= BT_UNKNOWN
)
1399 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1400 if (!(sym
->ts
.type
== ts
->type
1401 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1402 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1405 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1408 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1409 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1413 flavor
= sym
->attr
.flavor
;
1415 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1416 || flavor
== FL_LABEL
1417 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1418 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1420 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1429 /* Clears all attributes. */
1432 gfc_clear_attr (symbol_attribute
*attr
)
1434 memset (attr
, 0, sizeof (symbol_attribute
));
1438 /* Check for missing attributes in the new symbol. Currently does
1439 nothing, but it's not clear that it is unnecessary yet. */
1442 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1443 locus
*where ATTRIBUTE_UNUSED
)
1450 /* Copy an attribute to a symbol attribute, bit by bit. Some
1451 attributes have a lot of side-effects but cannot be present given
1452 where we are called from, so we ignore some bits. */
1455 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1457 int is_proc_lang_bind_spec
;
1459 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1462 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1464 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1466 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1468 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1470 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1472 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1474 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1476 if (src
->threadprivate
1477 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1479 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1481 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1483 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1488 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1491 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1494 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1496 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1498 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1501 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1503 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1505 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1507 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1510 if (src
->flavor
!= FL_UNKNOWN
1511 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1514 if (src
->intent
!= INTENT_UNKNOWN
1515 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1518 if (src
->access
!= ACCESS_UNKNOWN
1519 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1522 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1525 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1527 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1530 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1532 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1536 if (src
->is_c_interop
)
1537 dest
->is_c_interop
= 1;
1541 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1543 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1553 /************** Component name management ************/
1555 /* Component names of a derived type form their own little namespaces
1556 that are separate from all other spaces. The space is composed of
1557 a singly linked list of gfc_component structures whose head is
1558 located in the parent symbol. */
1561 /* Add a component name to a symbol. The call fails if the name is
1562 already present. On success, the component pointer is modified to
1563 point to the additional component structure. */
1566 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1567 gfc_component
**component
)
1569 gfc_component
*p
, *tail
;
1573 for (p
= sym
->components
; p
; p
= p
->next
)
1575 if (strcmp (p
->name
, name
) == 0)
1577 gfc_error ("Component '%s' at %C already declared at %L",
1585 /* Allocate a new component. */
1586 p
= gfc_get_component ();
1589 sym
->components
= p
;
1593 p
->name
= gfc_get_string (name
);
1594 p
->loc
= gfc_current_locus
;
1601 /* Recursive function to switch derived types of all symbol in a
1605 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1613 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1614 sym
->ts
.derived
= to
;
1616 switch_types (st
->left
, from
, to
);
1617 switch_types (st
->right
, from
, to
);
1621 /* This subroutine is called when a derived type is used in order to
1622 make the final determination about which version to use. The
1623 standard requires that a type be defined before it is 'used', but
1624 such types can appear in IMPLICIT statements before the actual
1625 definition. 'Using' in this context means declaring a variable to
1626 be that type or using the type constructor.
1628 If a type is used and the components haven't been defined, then we
1629 have to have a derived type in a parent unit. We find the node in
1630 the other namespace and point the symtree node in this namespace to
1631 that node. Further reference to this name point to the correct
1632 node. If we can't find the node in a parent namespace, then we have
1635 This subroutine takes a pointer to a symbol node and returns a
1636 pointer to the translated node or NULL for an error. Usually there
1637 is no translation and we return the node we were passed. */
1640 gfc_use_derived (gfc_symbol
*sym
)
1647 if (sym
->components
!= NULL
)
1648 return sym
; /* Already defined. */
1650 if (sym
->ns
->parent
== NULL
)
1653 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1655 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1659 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1662 /* Get rid of symbol sym, translating all references to s. */
1663 for (i
= 0; i
< GFC_LETTERS
; i
++)
1665 t
= &sym
->ns
->default_type
[i
];
1666 if (t
->derived
== sym
)
1670 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1675 /* Unlink from list of modified symbols. */
1676 gfc_commit_symbol (sym
);
1678 switch_types (sym
->ns
->sym_root
, sym
, s
);
1680 /* TODO: Also have to replace sym -> s in other lists like
1681 namelists, common lists and interface lists. */
1682 gfc_free_symbol (sym
);
1687 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1693 /* Given a derived type node and a component name, try to locate the
1694 component structure. Returns the NULL pointer if the component is
1695 not found or the components are private. */
1698 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1705 sym
= gfc_use_derived (sym
);
1710 for (p
= sym
->components
; p
; p
= p
->next
)
1711 if (strcmp (p
->name
, name
) == 0)
1715 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1719 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1720 || p
->access
== ACCESS_PRIVATE
))
1722 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1732 /* Given a symbol, free all of the component structures and everything
1736 free_components (gfc_component
*p
)
1744 gfc_free_array_spec (p
->as
);
1745 gfc_free_expr (p
->initializer
);
1752 /* Set component attributes from a standard symbol attribute structure. */
1755 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1758 c
->dimension
= attr
->dimension
;
1759 c
->pointer
= attr
->pointer
;
1760 c
->allocatable
= attr
->allocatable
;
1761 c
->access
= attr
->access
;
1765 /* Get a standard symbol attribute structure given the component
1769 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1772 gfc_clear_attr (attr
);
1773 attr
->dimension
= c
->dimension
;
1774 attr
->pointer
= c
->pointer
;
1775 attr
->allocatable
= c
->allocatable
;
1776 attr
->access
= c
->access
;
1780 /******************** Statement label management ********************/
1782 /* Comparison function for statement labels, used for managing the
1786 compare_st_labels (void *a1
, void *b1
)
1788 int a
= ((gfc_st_label
*) a1
)->value
;
1789 int b
= ((gfc_st_label
*) b1
)->value
;
1795 /* Free a single gfc_st_label structure, making sure the tree is not
1796 messed up. This function is called only when some parse error
1800 gfc_free_st_label (gfc_st_label
*label
)
1806 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1808 if (label
->format
!= NULL
)
1809 gfc_free_expr (label
->format
);
1815 /* Free a whole tree of gfc_st_label structures. */
1818 free_st_labels (gfc_st_label
*label
)
1824 free_st_labels (label
->left
);
1825 free_st_labels (label
->right
);
1827 if (label
->format
!= NULL
)
1828 gfc_free_expr (label
->format
);
1833 /* Given a label number, search for and return a pointer to the label
1834 structure, creating it if it does not exist. */
1837 gfc_get_st_label (int labelno
)
1841 /* First see if the label is already in this namespace. */
1842 lp
= gfc_current_ns
->st_labels
;
1845 if (lp
->value
== labelno
)
1848 if (lp
->value
< labelno
)
1854 lp
= gfc_getmem (sizeof (gfc_st_label
));
1856 lp
->value
= labelno
;
1857 lp
->defined
= ST_LABEL_UNKNOWN
;
1858 lp
->referenced
= ST_LABEL_UNKNOWN
;
1860 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1866 /* Called when a statement with a statement label is about to be
1867 accepted. We add the label to the list of the current namespace,
1868 making sure it hasn't been defined previously and referenced
1872 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1876 labelno
= lp
->value
;
1878 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1879 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1880 &lp
->where
, label_locus
);
1883 lp
->where
= *label_locus
;
1887 case ST_LABEL_FORMAT
:
1888 if (lp
->referenced
== ST_LABEL_TARGET
)
1889 gfc_error ("Label %d at %C already referenced as branch target",
1892 lp
->defined
= ST_LABEL_FORMAT
;
1896 case ST_LABEL_TARGET
:
1897 if (lp
->referenced
== ST_LABEL_FORMAT
)
1898 gfc_error ("Label %d at %C already referenced as a format label",
1901 lp
->defined
= ST_LABEL_TARGET
;
1906 lp
->defined
= ST_LABEL_BAD_TARGET
;
1907 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1913 /* Reference a label. Given a label and its type, see if that
1914 reference is consistent with what is known about that label,
1915 updating the unknown state. Returns FAILURE if something goes
1919 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1921 gfc_sl_type label_type
;
1928 labelno
= lp
->value
;
1930 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1931 label_type
= lp
->defined
;
1934 label_type
= lp
->referenced
;
1935 lp
->where
= gfc_current_locus
;
1938 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1940 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1945 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1946 && type
== ST_LABEL_FORMAT
)
1948 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1953 lp
->referenced
= type
;
1961 /*******A helper function for creating new expressions*************/
1965 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
1968 lval
= gfc_get_expr ();
1969 lval
->expr_type
= EXPR_VARIABLE
;
1970 lval
->where
= sym
->declared_at
;
1972 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1974 /* It will always be a full array. */
1975 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
1978 lval
->ref
= gfc_get_ref ();
1979 lval
->ref
->type
= REF_ARRAY
;
1980 lval
->ref
->u
.ar
.type
= AR_FULL
;
1981 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
1982 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
1983 lval
->ref
->u
.ar
.as
= sym
->as
;
1990 /************** Symbol table management subroutines ****************/
1992 /* Basic details: Fortran 95 requires a potentially unlimited number
1993 of distinct namespaces when compiling a program unit. This case
1994 occurs during a compilation of internal subprograms because all of
1995 the internal subprograms must be read before we can start
1996 generating code for the host.
1998 Given the tricky nature of the Fortran grammar, we must be able to
1999 undo changes made to a symbol table if the current interpretation
2000 of a statement is found to be incorrect. Whenever a symbol is
2001 looked up, we make a copy of it and link to it. All of these
2002 symbols are kept in a singly linked list so that we can commit or
2003 undo the changes at a later time.
2005 A symtree may point to a symbol node outside of its namespace. In
2006 this case, that symbol has been used as a host associated variable
2007 at some previous time. */
2009 /* Allocate a new namespace structure. Copies the implicit types from
2010 PARENT if PARENT_TYPES is set. */
2013 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2017 gfc_intrinsic_op in
;
2020 ns
= gfc_getmem (sizeof (gfc_namespace
));
2021 ns
->sym_root
= NULL
;
2022 ns
->uop_root
= NULL
;
2023 ns
->default_access
= ACCESS_UNKNOWN
;
2024 ns
->parent
= parent
;
2026 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2027 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2029 /* Initialize default implicit types. */
2030 for (i
= 'a'; i
<= 'z'; i
++)
2032 ns
->set_flag
[i
- 'a'] = 0;
2033 ts
= &ns
->default_type
[i
- 'a'];
2035 if (parent_types
&& ns
->parent
!= NULL
)
2037 /* Copy parent settings. */
2038 *ts
= ns
->parent
->default_type
[i
- 'a'];
2042 if (gfc_option
.flag_implicit_none
!= 0)
2048 if ('i' <= i
&& i
<= 'n')
2050 ts
->type
= BT_INTEGER
;
2051 ts
->kind
= gfc_default_integer_kind
;
2056 ts
->kind
= gfc_default_real_kind
;
2066 /* Comparison function for symtree nodes. */
2069 compare_symtree (void *_st1
, void *_st2
)
2071 gfc_symtree
*st1
, *st2
;
2073 st1
= (gfc_symtree
*) _st1
;
2074 st2
= (gfc_symtree
*) _st2
;
2076 return strcmp (st1
->name
, st2
->name
);
2080 /* Allocate a new symtree node and associate it with the new symbol. */
2083 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2087 st
= gfc_getmem (sizeof (gfc_symtree
));
2088 st
->name
= gfc_get_string (name
);
2090 gfc_insert_bbt (root
, st
, compare_symtree
);
2095 /* Delete a symbol from the tree. Does not free the symbol itself! */
2098 delete_symtree (gfc_symtree
**root
, const char *name
)
2100 gfc_symtree st
, *st0
;
2102 st0
= gfc_find_symtree (*root
, name
);
2104 st
.name
= gfc_get_string (name
);
2105 gfc_delete_bbt (root
, &st
, compare_symtree
);
2111 /* Given a root symtree node and a name, try to find the symbol within
2112 the namespace. Returns NULL if the symbol is not found. */
2115 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2121 c
= strcmp (name
, st
->name
);
2125 st
= (c
< 0) ? st
->left
: st
->right
;
2132 /* Return a symtree node with a name that is guaranteed to be unique
2133 within the namespace and corresponds to an illegal fortran name. */
2136 gfc_get_unique_symtree (gfc_namespace
*ns
)
2138 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2139 static int serial
= 0;
2141 sprintf (name
, "@%d", serial
++);
2142 return gfc_new_symtree (&ns
->sym_root
, name
);
2146 /* Given a name find a user operator node, creating it if it doesn't
2147 exist. These are much simpler than symbols because they can't be
2148 ambiguous with one another. */
2151 gfc_get_uop (const char *name
)
2156 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2160 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2162 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2163 uop
->name
= gfc_get_string (name
);
2164 uop
->access
= ACCESS_UNKNOWN
;
2165 uop
->ns
= gfc_current_ns
;
2171 /* Given a name find the user operator node. Returns NULL if it does
2175 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2180 ns
= gfc_current_ns
;
2182 st
= gfc_find_symtree (ns
->uop_root
, name
);
2183 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2187 /* Remove a gfc_symbol structure and everything it points to. */
2190 gfc_free_symbol (gfc_symbol
*sym
)
2196 gfc_free_array_spec (sym
->as
);
2198 free_components (sym
->components
);
2200 gfc_free_expr (sym
->value
);
2202 gfc_free_namelist (sym
->namelist
);
2204 gfc_free_namespace (sym
->formal_ns
);
2206 if (!sym
->attr
.generic_copy
)
2207 gfc_free_interface (sym
->generic
);
2209 gfc_free_formal_arglist (sym
->formal
);
2215 /* Allocate and initialize a new symbol node. */
2218 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2222 p
= gfc_getmem (sizeof (gfc_symbol
));
2224 gfc_clear_ts (&p
->ts
);
2225 gfc_clear_attr (&p
->attr
);
2228 p
->declared_at
= gfc_current_locus
;
2230 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2231 gfc_internal_error ("new_symbol(): Symbol name too long");
2233 p
->name
= gfc_get_string (name
);
2235 /* Make sure flags for symbol being C bound are clear initially. */
2236 p
->attr
.is_bind_c
= 0;
2237 p
->attr
.is_iso_c
= 0;
2238 /* Make sure the binding label field has a Nul char to start. */
2239 p
->binding_label
[0] = '\0';
2241 /* Clear the ptrs we may need. */
2242 p
->common_block
= NULL
;
2248 /* Generate an error if a symbol is ambiguous. */
2251 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2254 if (st
->n
.sym
->module
)
2255 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2256 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2258 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2259 "from current program unit", name
, st
->n
.sym
->name
);
2263 /* Search for a symtree starting in the current namespace, resorting to
2264 any parent namespaces if requested by a nonzero parent_flag.
2265 Returns nonzero if the name is ambiguous. */
2268 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2269 gfc_symtree
**result
)
2274 ns
= gfc_current_ns
;
2278 st
= gfc_find_symtree (ns
->sym_root
, name
);
2282 /* Ambiguous generic interfaces are permitted, as long
2283 as the specific interfaces are different. */
2284 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2286 ambiguous_symbol (name
, st
);
2305 /* Same, but returns the symbol instead. */
2308 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2309 gfc_symbol
**result
)
2314 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2319 *result
= st
->n
.sym
;
2325 /* Save symbol with the information necessary to back it out. */
2328 save_symbol_data (gfc_symbol
*sym
)
2331 if (sym
->new || sym
->old_symbol
!= NULL
)
2334 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2335 *(sym
->old_symbol
) = *sym
;
2337 sym
->tlink
= changed_syms
;
2342 /* Given a name, find a symbol, or create it if it does not exist yet
2343 in the current namespace. If the symbol is found we make sure that
2346 The integer return code indicates
2348 1 The symbol name was ambiguous
2349 2 The name meant to be established was already host associated.
2351 So if the return value is nonzero, then an error was issued. */
2354 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2359 /* This doesn't usually happen during resolution. */
2361 ns
= gfc_current_ns
;
2363 /* Try to find the symbol in ns. */
2364 st
= gfc_find_symtree (ns
->sym_root
, name
);
2368 /* If not there, create a new symbol. */
2369 p
= gfc_new_symbol (name
, ns
);
2371 /* Add to the list of tentative symbols. */
2372 p
->old_symbol
= NULL
;
2373 p
->tlink
= changed_syms
;
2378 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2385 /* Make sure the existing symbol is OK. Ambiguous
2386 generic interfaces are permitted, as long as the
2387 specific interfaces are different. */
2388 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2390 ambiguous_symbol (name
, st
);
2396 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2398 /* Symbol is from another namespace. */
2399 gfc_error ("Symbol '%s' at %C has already been host associated",
2406 /* Copy in case this symbol is changed. */
2407 save_symbol_data (p
);
2416 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2421 i
= gfc_get_sym_tree (name
, ns
, &st
);
2426 *result
= st
->n
.sym
;
2433 /* Subroutine that searches for a symbol, creating it if it doesn't
2434 exist, but tries to host-associate the symbol if possible. */
2437 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2442 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2445 save_symbol_data (st
->n
.sym
);
2450 if (gfc_current_ns
->parent
!= NULL
)
2452 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2463 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2468 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2473 i
= gfc_get_ha_sym_tree (name
, &st
);
2476 *result
= st
->n
.sym
;
2483 /* Return true if both symbols could refer to the same data object. Does
2484 not take account of aliasing due to equivalence statements. */
2487 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2489 /* Aliasing isn't possible if the symbols have different base types. */
2490 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2493 /* Pointers can point to other pointers, target objects and allocatable
2494 objects. Two allocatable objects cannot share the same storage. */
2495 if (lsym
->attr
.pointer
2496 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2498 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2500 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2507 /* Undoes all the changes made to symbols in the current statement.
2508 This subroutine is made simpler due to the fact that attributes are
2509 never removed once added. */
2512 gfc_undo_symbols (void)
2514 gfc_symbol
*p
, *q
, *old
;
2516 for (p
= changed_syms
; p
; p
= q
)
2522 /* Symbol was new. */
2523 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2527 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2529 gfc_free_symbol (p
);
2533 /* Restore previous state of symbol. Just copy simple stuff. */
2535 old
= p
->old_symbol
;
2537 p
->ts
.type
= old
->ts
.type
;
2538 p
->ts
.kind
= old
->ts
.kind
;
2540 p
->attr
= old
->attr
;
2542 if (p
->value
!= old
->value
)
2544 gfc_free_expr (old
->value
);
2548 if (p
->as
!= old
->as
)
2551 gfc_free_array_spec (p
->as
);
2555 p
->generic
= old
->generic
;
2556 p
->component_access
= old
->component_access
;
2558 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2560 gfc_free_namelist (p
->namelist
);
2565 if (p
->namelist_tail
!= old
->namelist_tail
)
2567 gfc_free_namelist (old
->namelist_tail
);
2568 old
->namelist_tail
->next
= NULL
;
2572 p
->namelist_tail
= old
->namelist_tail
;
2574 if (p
->formal
!= old
->formal
)
2576 gfc_free_formal_arglist (p
->formal
);
2577 p
->formal
= old
->formal
;
2580 gfc_free (p
->old_symbol
);
2581 p
->old_symbol
= NULL
;
2585 changed_syms
= NULL
;
2589 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2590 components of old_symbol that might need deallocation are the "allocatables"
2591 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2592 namelist_tail. In case these differ between old_symbol and sym, it's just
2593 because sym->namelist has gotten a few more items. */
2596 free_old_symbol (gfc_symbol
*sym
)
2599 if (sym
->old_symbol
== NULL
)
2602 if (sym
->old_symbol
->as
!= sym
->as
)
2603 gfc_free_array_spec (sym
->old_symbol
->as
);
2605 if (sym
->old_symbol
->value
!= sym
->value
)
2606 gfc_free_expr (sym
->old_symbol
->value
);
2608 if (sym
->old_symbol
->formal
!= sym
->formal
)
2609 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2611 gfc_free (sym
->old_symbol
);
2612 sym
->old_symbol
= NULL
;
2616 /* Makes the changes made in the current statement permanent-- gets
2617 rid of undo information. */
2620 gfc_commit_symbols (void)
2624 for (p
= changed_syms
; p
; p
= q
)
2630 free_old_symbol (p
);
2632 changed_syms
= NULL
;
2636 /* Makes the changes made in one symbol permanent -- gets rid of undo
2640 gfc_commit_symbol (gfc_symbol
*sym
)
2644 if (changed_syms
== sym
)
2645 changed_syms
= sym
->tlink
;
2648 for (p
= changed_syms
; p
; p
= p
->tlink
)
2649 if (p
->tlink
== sym
)
2651 p
->tlink
= sym
->tlink
;
2660 free_old_symbol (sym
);
2664 /* Recursive function that deletes an entire tree and all the common
2665 head structures it points to. */
2668 free_common_tree (gfc_symtree
* common_tree
)
2670 if (common_tree
== NULL
)
2673 free_common_tree (common_tree
->left
);
2674 free_common_tree (common_tree
->right
);
2676 gfc_free (common_tree
);
2680 /* Recursive function that deletes an entire tree and all the user
2681 operator nodes that it contains. */
2684 free_uop_tree (gfc_symtree
*uop_tree
)
2687 if (uop_tree
== NULL
)
2690 free_uop_tree (uop_tree
->left
);
2691 free_uop_tree (uop_tree
->right
);
2693 gfc_free_interface (uop_tree
->n
.uop
->operator);
2695 gfc_free (uop_tree
->n
.uop
);
2696 gfc_free (uop_tree
);
2700 /* Recursive function that deletes an entire tree and all the symbols
2701 that it contains. */
2704 free_sym_tree (gfc_symtree
*sym_tree
)
2709 if (sym_tree
== NULL
)
2712 free_sym_tree (sym_tree
->left
);
2713 free_sym_tree (sym_tree
->right
);
2715 sym
= sym_tree
->n
.sym
;
2719 gfc_internal_error ("free_sym_tree(): Negative refs");
2721 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2723 /* As formal_ns contains a reference to sym, delete formal_ns just
2724 before the deletion of sym. */
2725 ns
= sym
->formal_ns
;
2726 sym
->formal_ns
= NULL
;
2727 gfc_free_namespace (ns
);
2729 else if (sym
->refs
== 0)
2731 /* Go ahead and delete the symbol. */
2732 gfc_free_symbol (sym
);
2735 gfc_free (sym_tree
);
2739 /* Free the derived type list. */
2742 gfc_free_dt_list (void)
2744 gfc_dt_list
*dt
, *n
;
2746 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2752 gfc_derived_types
= NULL
;
2756 /* Free the gfc_equiv_info's. */
2759 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2763 gfc_free_equiv_infos (s
->next
);
2768 /* Free the gfc_equiv_lists. */
2771 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2775 gfc_free_equiv_lists (l
->next
);
2776 gfc_free_equiv_infos (l
->equiv
);
2781 /* Free a namespace structure and everything below it. Interface
2782 lists associated with intrinsic operators are not freed. These are
2783 taken care of when a specific name is freed. */
2786 gfc_free_namespace (gfc_namespace
*ns
)
2788 gfc_charlen
*cl
, *cl2
;
2789 gfc_namespace
*p
, *q
;
2798 gcc_assert (ns
->refs
== 0);
2800 gfc_free_statements (ns
->code
);
2802 free_sym_tree (ns
->sym_root
);
2803 free_uop_tree (ns
->uop_root
);
2804 free_common_tree (ns
->common_root
);
2806 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2809 gfc_free_expr (cl
->length
);
2813 free_st_labels (ns
->st_labels
);
2815 gfc_free_equiv (ns
->equiv
);
2816 gfc_free_equiv_lists (ns
->equiv_lists
);
2818 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2819 gfc_free_interface (ns
->operator[i
]);
2821 gfc_free_data (ns
->data
);
2825 /* Recursively free any contained namespaces. */
2830 gfc_free_namespace (q
);
2836 gfc_symbol_init_2 (void)
2839 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2844 gfc_symbol_done_2 (void)
2847 gfc_free_namespace (gfc_current_ns
);
2848 gfc_current_ns
= NULL
;
2849 gfc_free_dt_list ();
2853 /* Clear mark bits from symbol nodes associated with a symtree node. */
2856 clear_sym_mark (gfc_symtree
*st
)
2859 st
->n
.sym
->mark
= 0;
2863 /* Recursively traverse the symtree nodes. */
2866 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2872 gfc_traverse_symtree (st
->left
, func
);
2873 gfc_traverse_symtree (st
->right
, func
);
2878 /* Recursive namespace traversal function. */
2881 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2887 if (st
->n
.sym
->mark
== 0)
2888 (*func
) (st
->n
.sym
);
2889 st
->n
.sym
->mark
= 1;
2891 traverse_ns (st
->left
, func
);
2892 traverse_ns (st
->right
, func
);
2896 /* Call a given function for all symbols in the namespace. We take
2897 care that each gfc_symbol node is called exactly once. */
2900 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2903 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2905 traverse_ns (ns
->sym_root
, func
);
2909 /* Return TRUE if the symbol is an automatic variable. */
2912 gfc_is_var_automatic (gfc_symbol
*sym
)
2914 /* Pointer and allocatable variables are never automatic. */
2915 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2917 /* Check for arrays with non-constant size. */
2918 if (sym
->attr
.dimension
&& sym
->as
2919 && !gfc_is_compile_time_shape (sym
->as
))
2921 /* Check for non-constant length character variables. */
2922 if (sym
->ts
.type
== BT_CHARACTER
2924 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2929 /* Given a symbol, mark it as SAVEd if it is allowed. */
2932 save_symbol (gfc_symbol
*sym
)
2935 if (sym
->attr
.use_assoc
)
2938 if (sym
->attr
.in_common
2940 || sym
->attr
.flavor
!= FL_VARIABLE
)
2942 /* Automatic objects are not saved. */
2943 if (gfc_is_var_automatic (sym
))
2945 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2949 /* Mark those symbols which can be SAVEd as such. */
2952 gfc_save_all (gfc_namespace
*ns
)
2955 gfc_traverse_ns (ns
, save_symbol
);
2960 /* Make sure that no changes to symbols are pending. */
2963 gfc_symbol_state(void) {
2965 if (changed_syms
!= NULL
)
2966 gfc_internal_error("Symbol changes still pending!");
2971 /************** Global symbol handling ************/
2974 /* Search a tree for the global symbol. */
2977 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2986 c
= strcmp (name
, symbol
->name
);
2990 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2997 /* Compare two global symbols. Used for managing the BB tree. */
3000 gsym_compare (void *_s1
, void *_s2
)
3002 gfc_gsymbol
*s1
, *s2
;
3004 s1
= (gfc_gsymbol
*) _s1
;
3005 s2
= (gfc_gsymbol
*) _s2
;
3006 return strcmp (s1
->name
, s2
->name
);
3010 /* Get a global symbol, creating it if it doesn't exist. */
3013 gfc_get_gsymbol (const char *name
)
3017 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3021 s
= gfc_getmem (sizeof (gfc_gsymbol
));
3022 s
->type
= GSYM_UNKNOWN
;
3023 s
->name
= gfc_get_string (name
);
3025 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3032 get_iso_c_binding_dt (int sym_id
)
3034 gfc_dt_list
*dt_list
;
3036 dt_list
= gfc_derived_types
;
3038 /* Loop through the derived types in the name list, searching for
3039 the desired symbol from iso_c_binding. Search the parent namespaces
3040 if necessary and requested to (parent_flag). */
3041 while (dt_list
!= NULL
)
3043 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3044 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3045 return dt_list
->derived
;
3047 dt_list
= dt_list
->next
;
3054 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3055 with C. This is necessary for any derived type that is BIND(C) and for
3056 derived types that are parameters to functions that are BIND(C). All
3057 fields of the derived type are required to be interoperable, and are tested
3058 for such. If an error occurs, the errors are reported here, allowing for
3059 multiple errors to be handled for a single derived type. */
3062 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3064 gfc_component
*curr_comp
= NULL
;
3065 try is_c_interop
= FAILURE
;
3066 try retval
= SUCCESS
;
3068 if (derived_sym
== NULL
)
3069 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3070 "unexpectedly NULL");
3072 /* If we've already looked at this derived symbol, do not look at it again
3073 so we don't repeat warnings/errors. */
3074 if (derived_sym
->ts
.is_c_interop
)
3077 /* The derived type must have the BIND attribute to be interoperable
3078 J3/04-007, Section 15.2.3. */
3079 if (derived_sym
->attr
.is_bind_c
!= 1)
3081 derived_sym
->ts
.is_c_interop
= 0;
3082 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3083 "attribute to be C interoperable", derived_sym
->name
,
3084 &(derived_sym
->declared_at
));
3088 curr_comp
= derived_sym
->components
;
3090 /* TODO: is this really an error? */
3091 if (curr_comp
== NULL
)
3093 gfc_error ("Derived type '%s' at %L is empty",
3094 derived_sym
->name
, &(derived_sym
->declared_at
));
3098 /* Initialize the derived type as being C interoperable.
3099 If we find an error in the components, this will be set false. */
3100 derived_sym
->ts
.is_c_interop
= 1;
3102 /* Loop through the list of components to verify that the kind of
3103 each is a C interoperable type. */
3106 /* The components cannot be pointers (fortran sense).
3107 J3/04-007, Section 15.2.3, C1505. */
3108 if (curr_comp
->pointer
!= 0)
3110 gfc_error ("Component '%s' at %L cannot have the "
3111 "POINTER attribute because it is a member "
3112 "of the BIND(C) derived type '%s' at %L",
3113 curr_comp
->name
, &(curr_comp
->loc
),
3114 derived_sym
->name
, &(derived_sym
->declared_at
));
3118 /* The components cannot be allocatable.
3119 J3/04-007, Section 15.2.3, C1505. */
3120 if (curr_comp
->allocatable
!= 0)
3122 gfc_error ("Component '%s' at %L cannot have the "
3123 "ALLOCATABLE attribute because it is a member "
3124 "of the BIND(C) derived type '%s' at %L",
3125 curr_comp
->name
, &(curr_comp
->loc
),
3126 derived_sym
->name
, &(derived_sym
->declared_at
));
3130 /* BIND(C) derived types must have interoperable components. */
3131 if (curr_comp
->ts
.type
== BT_DERIVED
3132 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3133 && curr_comp
->ts
.derived
!= derived_sym
)
3135 /* This should be allowed; the draft says a derived-type can not
3136 have type parameters if it is has the BIND attribute. Type
3137 parameters seem to be for making parameterized derived types.
3138 There's no need to verify the type if it is c_ptr/c_funptr. */
3139 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3143 /* Grab the typespec for the given component and test the kind. */
3144 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3147 if (is_c_interop
!= SUCCESS
)
3149 /* Report warning and continue since not fatal. The
3150 draft does specify a constraint that requires all fields
3151 to interoperate, but if the user says real(4), etc., it
3152 may interoperate with *something* in C, but the compiler
3153 most likely won't know exactly what. Further, it may not
3154 interoperate with the same data type(s) in C if the user
3155 recompiles with different flags (e.g., -m32 and -m64 on
3156 x86_64 and using integer(4) to claim interop with a
3158 if (derived_sym
->attr
.is_bind_c
== 1)
3159 /* If the derived type is bind(c), all fields must be
3161 gfc_warning ("Component '%s' in derived type '%s' at %L "
3162 "may not be C interoperable, even though "
3163 "derived type '%s' is BIND(C)",
3164 curr_comp
->name
, derived_sym
->name
,
3165 &(curr_comp
->loc
), derived_sym
->name
);
3167 /* If derived type is param to bind(c) routine, or to one
3168 of the iso_c_binding procs, it must be interoperable, so
3169 all fields must interop too. */
3170 gfc_warning ("Component '%s' in derived type '%s' at %L "
3171 "may not be C interoperable",
3172 curr_comp
->name
, derived_sym
->name
,
3177 curr_comp
= curr_comp
->next
;
3178 } while (curr_comp
!= NULL
);
3181 /* Make sure we don't have conflicts with the attributes. */
3182 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3184 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3185 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3186 &(derived_sym
->declared_at
));
3190 if (derived_sym
->attr
.sequence
!= 0)
3192 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3193 "attribute because it is BIND(C)", derived_sym
->name
,
3194 &(derived_sym
->declared_at
));
3198 /* Mark the derived type as not being C interoperable if we found an
3199 error. If there were only warnings, proceed with the assumption
3200 it's interoperable. */
3201 if (retval
== FAILURE
)
3202 derived_sym
->ts
.is_c_interop
= 0;
3208 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3211 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3212 const char *module_name
)
3214 gfc_symtree
*tmp_symtree
;
3215 gfc_symbol
*tmp_sym
;
3217 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3219 if (tmp_symtree
!= NULL
)
3220 tmp_sym
= tmp_symtree
->n
.sym
;
3224 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3225 "create symbol for %s", ptr_name
);
3228 /* Set up the symbol's important fields. Save attr required so we can
3229 initialize the ptr to NULL. */
3230 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3231 tmp_sym
->ts
.is_c_interop
= 1;
3232 tmp_sym
->attr
.is_c_interop
= 1;
3233 tmp_sym
->ts
.is_iso_c
= 1;
3234 tmp_sym
->ts
.type
= BT_DERIVED
;
3236 /* The c_ptr and c_funptr derived types will provide the
3237 definition for c_null_ptr and c_null_funptr, respectively. */
3238 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3239 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3241 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3242 if (tmp_sym
->ts
.derived
== NULL
)
3244 /* This can occur if the user forgot to declare c_ptr or
3245 c_funptr and they're trying to use one of the procedures
3246 that has arg(s) of the missing type. In this case, a
3247 regular version of the thing should have been put in the
3249 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3250 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3251 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3252 ? "_gfortran_iso_c_binding_c_ptr"
3253 : "_gfortran_iso_c_binding_c_funptr"));
3255 tmp_sym
->ts
.derived
=
3256 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3257 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3260 /* Module name is some mangled version of iso_c_binding. */
3261 tmp_sym
->module
= gfc_get_string (module_name
);
3263 /* Say it's from the iso_c_binding module. */
3264 tmp_sym
->attr
.is_iso_c
= 1;
3266 tmp_sym
->attr
.use_assoc
= 1;
3267 tmp_sym
->attr
.is_bind_c
= 1;
3268 /* Set the binding_label. */
3269 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3271 /* Set the c_address field of c_null_ptr and c_null_funptr to
3272 the value of NULL. */
3273 tmp_sym
->value
= gfc_get_expr ();
3274 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3275 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3276 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3277 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3278 /* This line will initialize the c_null_ptr/c_null_funptr
3279 c_address field to NULL. */
3280 tmp_sym
->value
->value
.constructor
->expr
= gfc_int_expr (0);
3281 /* Must declare c_null_ptr and c_null_funptr as having the
3282 PARAMETER attribute so they can be used in init expressions. */
3283 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3289 /* Add a formal argument, gfc_formal_arglist, to the
3290 end of the given list of arguments. Set the reference to the
3291 provided symbol, param_sym, in the argument. */
3294 add_formal_arg (gfc_formal_arglist
**head
,
3295 gfc_formal_arglist
**tail
,
3296 gfc_formal_arglist
*formal_arg
,
3297 gfc_symbol
*param_sym
)
3299 /* Put in list, either as first arg or at the tail (curr arg). */
3301 *head
= *tail
= formal_arg
;
3304 (*tail
)->next
= formal_arg
;
3305 (*tail
) = formal_arg
;
3308 (*tail
)->sym
= param_sym
;
3309 (*tail
)->next
= NULL
;
3315 /* Generates a symbol representing the CPTR argument to an
3316 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3317 CPTR and add it to the provided argument list. */
3320 gen_cptr_param (gfc_formal_arglist
**head
,
3321 gfc_formal_arglist
**tail
,
3322 const char *module_name
,
3323 gfc_namespace
*ns
, const char *c_ptr_name
,
3326 gfc_symbol
*param_sym
= NULL
;
3327 gfc_symbol
*c_ptr_sym
= NULL
;
3328 gfc_symtree
*param_symtree
= NULL
;
3329 gfc_formal_arglist
*formal_arg
= NULL
;
3330 const char *c_ptr_in
;
3331 const char *c_ptr_type
= NULL
;
3333 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3334 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3336 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3338 if(c_ptr_name
== NULL
)
3339 c_ptr_in
= "gfc_cptr__";
3341 c_ptr_in
= c_ptr_name
;
3342 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3343 if (param_symtree
!= NULL
)
3344 param_sym
= param_symtree
->n
.sym
;
3346 gfc_internal_error ("gen_cptr_param(): Unable to "
3347 "create symbol for %s", c_ptr_in
);
3349 /* Set up the appropriate fields for the new c_ptr param sym. */
3351 param_sym
->attr
.flavor
= FL_DERIVED
;
3352 param_sym
->ts
.type
= BT_DERIVED
;
3353 param_sym
->attr
.intent
= INTENT_IN
;
3354 param_sym
->attr
.dummy
= 1;
3356 /* This will pass the ptr to the iso_c routines as a (void *). */
3357 param_sym
->attr
.value
= 1;
3358 param_sym
->attr
.use_assoc
= 1;
3360 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3362 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3363 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3365 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3366 if (c_ptr_sym
== NULL
)
3368 /* This can happen if the user did not define c_ptr but they are
3369 trying to use one of the iso_c_binding functions that need it. */
3370 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3371 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3372 (const char *)c_ptr_type
);
3374 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3375 (const char *)c_ptr_type
);
3377 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3380 param_sym
->ts
.derived
= c_ptr_sym
;
3381 param_sym
->module
= gfc_get_string (module_name
);
3383 /* Make new formal arg. */
3384 formal_arg
= gfc_get_formal_arglist ();
3385 /* Add arg to list of formal args (the CPTR arg). */
3386 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3390 /* Generates a symbol representing the FPTR argument to an
3391 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3392 FPTR and add it to the provided argument list. */
3395 gen_fptr_param (gfc_formal_arglist
**head
,
3396 gfc_formal_arglist
**tail
,
3397 const char *module_name
,
3398 gfc_namespace
*ns
, const char *f_ptr_name
)
3400 gfc_symbol
*param_sym
= NULL
;
3401 gfc_symtree
*param_symtree
= NULL
;
3402 gfc_formal_arglist
*formal_arg
= NULL
;
3403 const char *f_ptr_out
= "gfc_fptr__";
3405 if (f_ptr_name
!= NULL
)
3406 f_ptr_out
= f_ptr_name
;
3408 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3409 if (param_symtree
!= NULL
)
3410 param_sym
= param_symtree
->n
.sym
;
3412 gfc_internal_error ("generateFPtrParam(): Unable to "
3413 "create symbol for %s", f_ptr_out
);
3415 /* Set up the necessary fields for the fptr output param sym. */
3417 param_sym
->attr
.pointer
= 1;
3418 param_sym
->attr
.dummy
= 1;
3419 param_sym
->attr
.use_assoc
= 1;
3421 /* ISO C Binding type to allow any pointer type as actual param. */
3422 param_sym
->ts
.type
= BT_VOID
;
3423 param_sym
->module
= gfc_get_string (module_name
);
3426 formal_arg
= gfc_get_formal_arglist ();
3427 /* Add arg to list of formal args. */
3428 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3432 /* Generates a symbol representing the optional SHAPE argument for the
3433 iso_c_binding c_f_pointer() procedure. Also, create a
3434 gfc_formal_arglist for the SHAPE and add it to the provided
3438 gen_shape_param (gfc_formal_arglist
**head
,
3439 gfc_formal_arglist
**tail
,
3440 const char *module_name
,
3441 gfc_namespace
*ns
, const char *shape_param_name
)
3443 gfc_symbol
*param_sym
= NULL
;
3444 gfc_symtree
*param_symtree
= NULL
;
3445 gfc_formal_arglist
*formal_arg
= NULL
;
3446 const char *shape_param
= "gfc_shape_array__";
3449 if (shape_param_name
!= NULL
)
3450 shape_param
= shape_param_name
;
3452 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3453 if (param_symtree
!= NULL
)
3454 param_sym
= param_symtree
->n
.sym
;
3456 gfc_internal_error ("generateShapeParam(): Unable to "
3457 "create symbol for %s", shape_param
);
3459 /* Set up the necessary fields for the shape input param sym. */
3461 param_sym
->attr
.dummy
= 1;
3462 param_sym
->attr
.use_assoc
= 1;
3464 /* Integer array, rank 1, describing the shape of the object. Make it's
3465 type BT_VOID initially so we can accept any type/kind combination of
3466 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3467 of BT_INTEGER type. */
3468 param_sym
->ts
.type
= BT_VOID
;
3470 /* Initialize the kind to default integer. However, it will be overridden
3471 during resolution to match the kind of the SHAPE parameter given as
3472 the actual argument (to allow for any valid integer kind). */
3473 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3474 param_sym
->as
= gfc_get_array_spec ();
3476 /* Clear out the dimension info for the array. */
3477 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3479 param_sym
->as
->lower
[i
] = NULL
;
3480 param_sym
->as
->upper
[i
] = NULL
;
3482 param_sym
->as
->rank
= 1;
3483 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3485 /* The extent is unknown until we get it. The length give us
3486 the rank the incoming pointer. */
3487 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3489 /* The arg is also optional; it is required iff the second arg
3490 (fptr) is to an array, otherwise, it's ignored. */
3491 param_sym
->attr
.optional
= 1;
3492 param_sym
->attr
.intent
= INTENT_IN
;
3493 param_sym
->attr
.dimension
= 1;
3494 param_sym
->module
= gfc_get_string (module_name
);
3497 formal_arg
= gfc_get_formal_arglist ();
3498 /* Add arg to list of formal args. */
3499 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3502 /* Add a procedure interface to the given symbol (i.e., store a
3503 reference to the list of formal arguments). */
3506 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3507 gfc_formal_arglist
*formal
)
3510 sym
->formal
= formal
;
3511 sym
->attr
.if_source
= source
;
3515 /* Builds the parameter list for the iso_c_binding procedure
3516 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3517 generic version of either the c_f_pointer or c_f_procpointer
3518 functions. The new_proc_sym represents a "resolved" version of the
3519 symbol. The functions are resolved to match the types of their
3520 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3521 something similar to c_f_pointer_i4 if the type of data object fptr
3522 pointed to was a default integer. The actual name of the resolved
3523 procedure symbol is further mangled with the module name, etc., but
3524 the idea holds true. */
3527 build_formal_args (gfc_symbol
*new_proc_sym
,
3528 gfc_symbol
*old_sym
, int add_optional_arg
)
3530 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3531 gfc_namespace
*parent_ns
= NULL
;
3533 parent_ns
= gfc_current_ns
;
3534 /* Create a new namespace, which will be the formal ns (namespace
3535 of the formal args). */
3536 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3537 gfc_current_ns
->proc_name
= new_proc_sym
;
3539 /* Generate the params. */
3540 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3541 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3543 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3544 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3545 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3546 gfc_current_ns
, "fptr");
3548 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3549 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3551 gen_shape_param (&head
, &tail
,
3552 (const char *) new_proc_sym
->module
,
3553 gfc_current_ns
, "shape");
3556 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3558 /* c_associated has one required arg and one optional; both
3560 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3561 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3562 if (add_optional_arg
)
3564 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3565 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3566 /* The last param is optional so mark it as such. */
3567 tail
->sym
->attr
.optional
= 1;
3571 /* Add the interface (store formal args to new_proc_sym). */
3572 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3574 /* Set up the formal_ns pointer to the one created for the
3575 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3576 new_proc_sym
->formal_ns
= gfc_current_ns
;
3578 gfc_current_ns
= parent_ns
;
3582 /* Generate the given set of C interoperable kind objects, or all
3583 interoperable kinds. This function will only be given kind objects
3584 for valid iso_c_binding defined types because this is verified when
3585 the 'use' statement is parsed. If the user gives an 'only' clause,
3586 the specific kinds are looked up; if they don't exist, an error is
3587 reported. If the user does not give an 'only' clause, all
3588 iso_c_binding symbols are generated. If a list of specific kinds
3589 is given, it must have a NULL in the first empty spot to mark the
3594 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3595 const char *local_name
)
3597 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3598 : c_interop_kinds_table
[s
].name
;
3599 gfc_symtree
*tmp_symtree
= NULL
;
3600 gfc_symbol
*tmp_sym
= NULL
;
3601 gfc_dt_list
**dt_list_ptr
= NULL
;
3602 gfc_component
*tmp_comp
= NULL
;
3603 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3606 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3608 /* Already exists in this scope so don't re-add it.
3609 TODO: we should probably check that it's really the same symbol. */
3610 if (tmp_symtree
!= NULL
)
3613 /* Create the sym tree in the current ns. */
3614 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3616 tmp_sym
= tmp_symtree
->n
.sym
;
3618 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3621 /* Say what module this symbol belongs to. */
3622 tmp_sym
->module
= gfc_get_string (mod_name
);
3623 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3624 tmp_sym
->intmod_sym_id
= s
;
3629 #define NAMED_INTCST(a,b,c) case a :
3630 #define NAMED_REALCST(a,b,c) case a :
3631 #define NAMED_CMPXCST(a,b,c) case a :
3632 #define NAMED_LOGCST(a,b,c) case a :
3633 #define NAMED_CHARKNDCST(a,b,c) case a :
3634 #include "iso-c-binding.def"
3636 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3638 /* Initialize an integer constant expression node. */
3639 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3640 tmp_sym
->ts
.type
= BT_INTEGER
;
3641 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3643 /* Mark this type as a C interoperable one. */
3644 tmp_sym
->ts
.is_c_interop
= 1;
3645 tmp_sym
->ts
.is_iso_c
= 1;
3646 tmp_sym
->value
->ts
.is_c_interop
= 1;
3647 tmp_sym
->value
->ts
.is_iso_c
= 1;
3648 tmp_sym
->attr
.is_c_interop
= 1;
3650 /* Tell what f90 type this c interop kind is valid. */
3651 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3653 /* Say it's from the iso_c_binding module. */
3654 tmp_sym
->attr
.is_iso_c
= 1;
3656 /* Make it use associated. */
3657 tmp_sym
->attr
.use_assoc
= 1;
3661 #define NAMED_CHARCST(a,b,c) case a :
3662 #include "iso-c-binding.def"
3664 /* Initialize an integer constant expression node for the
3665 length of the character. */
3666 tmp_sym
->value
= gfc_get_expr ();
3667 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3668 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3669 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3670 tmp_sym
->value
->where
= gfc_current_locus
;
3671 tmp_sym
->value
->ts
.is_c_interop
= 1;
3672 tmp_sym
->value
->ts
.is_iso_c
= 1;
3673 tmp_sym
->value
->value
.character
.length
= 1;
3674 tmp_sym
->value
->value
.character
.string
= gfc_getmem (2);
3675 tmp_sym
->value
->value
.character
.string
[0]
3676 = (char) c_interop_kinds_table
[s
].value
;
3677 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3679 /* May not need this in both attr and ts, but do need in
3680 attr for writing module file. */
3681 tmp_sym
->attr
.is_c_interop
= 1;
3683 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3684 tmp_sym
->ts
.type
= BT_CHARACTER
;
3686 /* Need to set it to the C_CHAR kind. */
3687 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3689 /* Mark this type as a C interoperable one. */
3690 tmp_sym
->ts
.is_c_interop
= 1;
3691 tmp_sym
->ts
.is_iso_c
= 1;
3693 /* Tell what f90 type this c interop kind is valid. */
3694 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3696 /* Say it's from the iso_c_binding module. */
3697 tmp_sym
->attr
.is_iso_c
= 1;
3699 /* Make it use associated. */
3700 tmp_sym
->attr
.use_assoc
= 1;
3703 case ISOCBINDING_PTR
:
3704 case ISOCBINDING_FUNPTR
:
3706 /* Initialize an integer constant expression node. */
3707 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3708 tmp_sym
->ts
.is_c_interop
= 1;
3709 tmp_sym
->attr
.is_c_interop
= 1;
3710 tmp_sym
->attr
.is_iso_c
= 1;
3711 tmp_sym
->ts
.is_iso_c
= 1;
3712 tmp_sym
->ts
.type
= BT_DERIVED
;
3714 /* A derived type must have the bind attribute to be
3715 interoperable (J3/04-007, Section 15.2.3), even though
3716 the binding label is not used. */
3717 tmp_sym
->attr
.is_bind_c
= 1;
3719 tmp_sym
->attr
.referenced
= 1;
3721 tmp_sym
->ts
.derived
= tmp_sym
;
3723 /* Add the symbol created for the derived type to the current ns. */
3724 dt_list_ptr
= &(gfc_derived_types
);
3725 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3726 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3728 /* There is already at least one derived type in the list, so append
3729 the one we're currently building for c_ptr or c_funptr. */
3730 if (*dt_list_ptr
!= NULL
)
3731 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3732 (*dt_list_ptr
) = gfc_get_dt_list ();
3733 (*dt_list_ptr
)->derived
= tmp_sym
;
3734 (*dt_list_ptr
)->next
= NULL
;
3736 /* Set up the component of the derived type, which will be
3737 an integer with kind equal to c_ptr_size. Mangle the name of
3738 the field for the c_address to prevent the curious user from
3739 trying to access it from Fortran. */
3740 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3741 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3742 if (tmp_comp
== NULL
)
3743 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3744 "create component for c_address");
3746 tmp_comp
->ts
.type
= BT_INTEGER
;
3748 /* Set this because the module will need to read/write this field. */
3749 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3751 /* The kinds for c_ptr and c_funptr are the same. */
3752 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3753 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3755 tmp_comp
->pointer
= 0;
3756 tmp_comp
->dimension
= 0;
3758 /* Mark the component as C interoperable. */
3759 tmp_comp
->ts
.is_c_interop
= 1;
3761 /* Make it use associated (iso_c_binding module). */
3762 tmp_sym
->attr
.use_assoc
= 1;
3765 case ISOCBINDING_NULL_PTR
:
3766 case ISOCBINDING_NULL_FUNPTR
:
3767 gen_special_c_interop_ptr (s
, name
, mod_name
);
3770 case ISOCBINDING_F_POINTER
:
3771 case ISOCBINDING_ASSOCIATED
:
3772 case ISOCBINDING_LOC
:
3773 case ISOCBINDING_FUNLOC
:
3774 case ISOCBINDING_F_PROCPOINTER
:
3776 tmp_sym
->attr
.proc
= PROC_MODULE
;
3778 /* Use the procedure's name as it is in the iso_c_binding module for
3779 setting the binding label in case the user renamed the symbol. */
3780 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3781 c_interop_kinds_table
[s
].name
);
3782 tmp_sym
->attr
.is_iso_c
= 1;
3783 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3784 tmp_sym
->attr
.subroutine
= 1;
3787 /* TODO! This needs to be finished more for the expr of the
3788 function or something!
3789 This may not need to be here, because trying to do c_loc
3791 if (s
== ISOCBINDING_ASSOCIATED
)
3793 tmp_sym
->attr
.function
= 1;
3794 tmp_sym
->ts
.type
= BT_LOGICAL
;
3795 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3796 tmp_sym
->result
= tmp_sym
;
3800 /* Here, we're taking the simple approach. We're defining
3801 c_loc as an external identifier so the compiler will put
3802 what we expect on the stack for the address we want the
3804 tmp_sym
->ts
.type
= BT_DERIVED
;
3805 if (s
== ISOCBINDING_LOC
)
3806 tmp_sym
->ts
.derived
=
3807 get_iso_c_binding_dt (ISOCBINDING_PTR
);
3809 tmp_sym
->ts
.derived
=
3810 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3812 if (tmp_sym
->ts
.derived
== NULL
)
3814 /* Create the necessary derived type so we can continue
3815 processing the file. */
3816 generate_isocbinding_symbol
3817 (mod_name
, s
== ISOCBINDING_FUNLOC
3818 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
3819 (const char *)(s
== ISOCBINDING_FUNLOC
3820 ? "_gfortran_iso_c_binding_c_funptr"
3821 : "_gfortran_iso_c_binding_c_ptr"));
3822 tmp_sym
->ts
.derived
=
3823 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
3824 ? ISOCBINDING_FUNPTR
3828 /* The function result is itself (no result clause). */
3829 tmp_sym
->result
= tmp_sym
;
3830 tmp_sym
->attr
.external
= 1;
3831 tmp_sym
->attr
.use_assoc
= 0;
3832 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
3833 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
3837 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
3838 tmp_sym
->attr
.contained
= 0;
3840 /* Try using this builder routine, with the new and old symbols
3841 both being the generic iso_c proc sym being created. This
3842 will create the formal args (and the new namespace for them).
3843 Don't build an arg list for c_loc because we're going to treat
3844 c_loc as an external procedure. */
3845 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
3846 /* The 1 says to add any optional args, if applicable. */
3847 build_formal_args (tmp_sym
, tmp_sym
, 1);
3849 /* Set this after setting up the symbol, to prevent error messages. */
3850 tmp_sym
->attr
.use_assoc
= 1;
3852 /* This symbol will not be referenced directly. It will be
3853 resolved to the implementation for the given f90 kind. */
3854 tmp_sym
->attr
.referenced
= 0;
3864 /* Creates a new symbol based off of an old iso_c symbol, with a new
3865 binding label. This function can be used to create a new,
3866 resolved, version of a procedure symbol for c_f_pointer or
3867 c_f_procpointer that is based on the generic symbols. A new
3868 parameter list is created for the new symbol using
3869 build_formal_args(). The add_optional_flag specifies whether the
3870 to add the optional SHAPE argument. The new symbol is
3874 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
3875 char *new_binding_label
, int add_optional_arg
)
3877 gfc_symtree
*new_symtree
= NULL
;
3879 /* See if we have a symbol by that name already available, looking
3880 through any parent namespaces. */
3881 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
3882 if (new_symtree
!= NULL
)
3883 /* Return the existing symbol. */
3884 return new_symtree
->n
.sym
;
3886 /* Create the symtree/symbol, with attempted host association. */
3887 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
3888 if (new_symtree
== NULL
)
3889 gfc_internal_error ("get_iso_c_sym(): Unable to create "
3890 "symtree for '%s'", new_name
);
3892 /* Now fill in the fields of the resolved symbol with the old sym. */
3893 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
3894 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
3895 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
3896 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
3897 /* Build the formal arg list. */
3898 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
3900 gfc_commit_symbol (new_symtree
->n
.sym
);
3902 return new_symtree
->n
.sym
;