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)", *procedure
= "PROCEDURE";
356 static const char *threadprivate
= "THREADPRIVATE";
362 where
= &gfc_current_locus
;
364 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
368 standard
= GFC_STD_F2003
;
372 /* Check for attributes not allowed in a BLOCK DATA. */
373 if (gfc_current_state () == COMP_BLOCK_DATA
)
377 if (attr
->in_namelist
)
379 if (attr
->allocatable
)
385 if (attr
->access
== ACCESS_PRIVATE
)
387 if (attr
->access
== ACCESS_PUBLIC
)
389 if (attr
->intent
!= INTENT_UNKNOWN
)
395 ("%s attribute not allowed in BLOCK DATA program unit at %L",
401 if (attr
->save
== SAVE_EXPLICIT
)
404 conf (in_common
, save
);
407 switch (attr
->flavor
)
416 a1
= gfc_code2string (flavors
, attr
->flavor
);
428 conf (dummy
, intrinsic
);
429 conf (dummy
, threadprivate
);
430 conf (pointer
, target
);
431 conf (pointer
, intrinsic
);
432 conf (pointer
, elemental
);
433 conf (allocatable
, elemental
);
435 conf (target
, external
);
436 conf (target
, intrinsic
);
437 conf (external
, dimension
); /* See Fortran 95's R504. */
439 conf (external
, intrinsic
);
440 conf (entry
, intrinsic
);
442 if ((attr
->if_source
&& !attr
->procedure
) || attr
->contained
)
444 conf (external
, subroutine
);
445 conf (external
, function
);
448 conf (allocatable
, pointer
);
449 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
450 conf_std (allocatable
, function
, GFC_STD_F2003
);
451 conf_std (allocatable
, result
, GFC_STD_F2003
);
452 conf (elemental
, recursive
);
454 conf (in_common
, dummy
);
455 conf (in_common
, allocatable
);
456 conf (in_common
, result
);
458 conf (dummy
, result
);
460 conf (in_equivalence
, use_assoc
);
461 conf (in_equivalence
, dummy
);
462 conf (in_equivalence
, target
);
463 conf (in_equivalence
, pointer
);
464 conf (in_equivalence
, function
);
465 conf (in_equivalence
, result
);
466 conf (in_equivalence
, entry
);
467 conf (in_equivalence
, allocatable
);
468 conf (in_equivalence
, threadprivate
);
470 conf (in_namelist
, pointer
);
471 conf (in_namelist
, allocatable
);
473 conf (entry
, result
);
475 conf (function
, subroutine
);
477 if (!function
&& !subroutine
)
478 conf (is_bind_c
, dummy
);
480 conf (is_bind_c
, cray_pointer
);
481 conf (is_bind_c
, cray_pointee
);
482 conf (is_bind_c
, allocatable
);
484 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
485 Parameter conflict caught below. Also, value cannot be specified
486 for a dummy procedure. */
488 /* Cray pointer/pointee conflicts. */
489 conf (cray_pointer
, cray_pointee
);
490 conf (cray_pointer
, dimension
);
491 conf (cray_pointer
, pointer
);
492 conf (cray_pointer
, target
);
493 conf (cray_pointer
, allocatable
);
494 conf (cray_pointer
, external
);
495 conf (cray_pointer
, intrinsic
);
496 conf (cray_pointer
, in_namelist
);
497 conf (cray_pointer
, function
);
498 conf (cray_pointer
, subroutine
);
499 conf (cray_pointer
, entry
);
501 conf (cray_pointee
, allocatable
);
502 conf (cray_pointee
, intent
);
503 conf (cray_pointee
, optional
);
504 conf (cray_pointee
, dummy
);
505 conf (cray_pointee
, target
);
506 conf (cray_pointee
, intrinsic
);
507 conf (cray_pointee
, pointer
);
508 conf (cray_pointee
, entry
);
509 conf (cray_pointee
, in_common
);
510 conf (cray_pointee
, in_equivalence
);
511 conf (cray_pointee
, threadprivate
);
514 conf (data
, function
);
516 conf (data
, allocatable
);
517 conf (data
, use_assoc
);
519 conf (value
, pointer
)
520 conf (value
, allocatable
)
521 conf (value
, subroutine
)
522 conf (value
, function
)
523 conf (value
, volatile_
)
524 conf (value
, dimension
)
525 conf (value
, external
)
528 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
531 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
535 conf (protected, intrinsic
)
536 conf (protected, external
)
537 conf (protected, in_common
)
539 conf (volatile_
, intrinsic
)
540 conf (volatile_
, external
)
542 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
549 conf (procedure
, allocatable
)
550 conf (procedure
, dimension
)
551 conf (procedure
, intrinsic
)
552 conf (procedure
, protected)
553 conf (procedure
, target
)
554 conf (procedure
, value
)
555 conf (procedure
, volatile_
)
556 conf (procedure
, entry
)
557 /* TODO: Implement procedure pointers. */
558 if (attr
->procedure
&& attr
->pointer
)
560 gfc_error ("Fortran 2003: Procedure pointers at %L are "
561 "not yet implemented in gfortran", where
);
565 a1
= gfc_code2string (flavors
, attr
->flavor
);
567 if (attr
->in_namelist
568 && attr
->flavor
!= FL_VARIABLE
569 && attr
->flavor
!= FL_PROCEDURE
570 && attr
->flavor
!= FL_UNKNOWN
)
576 switch (attr
->flavor
)
596 conf2 (threadprivate
);
606 if (attr
->subroutine
)
615 conf2 (threadprivate
);
620 case PROC_ST_FUNCTION
:
632 conf2 (threadprivate
);
652 conf2 (threadprivate
);
654 if (attr
->intent
!= INTENT_UNKNOWN
)
676 conf2 (threadprivate
);
689 gfc_error ("%s attribute conflicts with %s attribute at %L",
692 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
693 a1
, a2
, name
, where
);
700 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
701 "with %s attribute at %L", a1
, a2
,
706 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
707 "with %s attribute in '%s' at %L",
708 a1
, a2
, name
, where
);
717 /* Mark a symbol as referenced. */
720 gfc_set_sym_referenced (gfc_symbol
*sym
)
723 if (sym
->attr
.referenced
)
726 sym
->attr
.referenced
= 1;
728 /* Remember which order dummy variables are accessed in. */
730 sym
->dummy_order
= next_dummy_order
++;
734 /* Common subroutine called by attribute changing subroutines in order
735 to prevent them from changing a symbol that has been
736 use-associated. Returns zero if it is OK to change the symbol,
740 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
743 if (attr
->use_assoc
== 0)
747 where
= &gfc_current_locus
;
750 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
753 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
760 /* Generate an error because of a duplicate attribute. */
763 duplicate_attr (const char *attr
, locus
*where
)
767 where
= &gfc_current_locus
;
769 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
773 /* Called from decl.c (attr_decl1) to check attributes, when declared
777 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
780 if (check_used (attr
, NULL
, where
))
783 return check_conflict (attr
, NULL
, where
);
787 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
790 if (check_used (attr
, NULL
, where
))
793 if (attr
->allocatable
)
795 duplicate_attr ("ALLOCATABLE", where
);
799 attr
->allocatable
= 1;
800 return check_conflict (attr
, NULL
, where
);
805 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
808 if (check_used (attr
, name
, where
))
813 duplicate_attr ("DIMENSION", where
);
818 return check_conflict (attr
, name
, where
);
823 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
826 if (check_used (attr
, NULL
, where
))
831 duplicate_attr ("EXTERNAL", where
);
837 return check_conflict (attr
, NULL
, where
);
842 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
845 if (check_used (attr
, NULL
, where
))
850 duplicate_attr ("INTRINSIC", where
);
856 return check_conflict (attr
, NULL
, where
);
861 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
864 if (check_used (attr
, NULL
, where
))
869 duplicate_attr ("OPTIONAL", where
);
874 return check_conflict (attr
, NULL
, where
);
879 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
882 if (check_used (attr
, NULL
, where
))
886 return check_conflict (attr
, NULL
, where
);
891 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
894 if (check_used (attr
, NULL
, where
))
897 attr
->cray_pointer
= 1;
898 return check_conflict (attr
, NULL
, where
);
903 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
906 if (check_used (attr
, NULL
, where
))
909 if (attr
->cray_pointee
)
911 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
912 " statements", where
);
916 attr
->cray_pointee
= 1;
917 return check_conflict (attr
, NULL
, where
);
922 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
924 if (check_used (attr
, name
, where
))
929 if (gfc_notify_std (GFC_STD_LEGACY
,
930 "Duplicate PROTECTED attribute specified at %L",
937 return check_conflict (attr
, name
, where
);
942 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
945 if (check_used (attr
, name
, where
))
949 return check_conflict (attr
, name
, where
);
954 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
957 if (check_used (attr
, name
, where
))
963 ("SAVE attribute at %L cannot be specified in a PURE procedure",
968 if (attr
->save
== SAVE_EXPLICIT
)
970 if (gfc_notify_std (GFC_STD_LEGACY
,
971 "Duplicate SAVE attribute specified at %L",
977 attr
->save
= SAVE_EXPLICIT
;
978 return check_conflict (attr
, name
, where
);
983 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
986 if (check_used (attr
, name
, where
))
991 if (gfc_notify_std (GFC_STD_LEGACY
,
992 "Duplicate VALUE attribute specified at %L",
999 return check_conflict (attr
, name
, where
);
1004 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1006 /* No check_used needed as 11.2.1 of the F2003 standard allows
1007 that the local identifier made accessible by a use statement can be
1008 given a VOLATILE attribute. */
1010 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1011 if (gfc_notify_std (GFC_STD_LEGACY
,
1012 "Duplicate VOLATILE attribute specified at %L", where
)
1016 attr
->volatile_
= 1;
1017 attr
->volatile_ns
= gfc_current_ns
;
1018 return check_conflict (attr
, name
, where
);
1023 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1026 if (check_used (attr
, name
, where
))
1029 if (attr
->threadprivate
)
1031 duplicate_attr ("THREADPRIVATE", where
);
1035 attr
->threadprivate
= 1;
1036 return check_conflict (attr
, name
, where
);
1041 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1044 if (check_used (attr
, NULL
, where
))
1049 duplicate_attr ("TARGET", where
);
1054 return check_conflict (attr
, NULL
, where
);
1059 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1062 if (check_used (attr
, name
, where
))
1065 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1067 return check_conflict (attr
, name
, where
);
1072 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1075 if (check_used (attr
, name
, where
))
1078 /* Duplicate attribute already checked for. */
1079 attr
->in_common
= 1;
1080 if (check_conflict (attr
, name
, where
) == FAILURE
)
1083 if (attr
->flavor
== FL_VARIABLE
)
1086 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1091 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1094 /* Duplicate attribute already checked for. */
1095 attr
->in_equivalence
= 1;
1096 if (check_conflict (attr
, name
, where
) == FAILURE
)
1099 if (attr
->flavor
== FL_VARIABLE
)
1102 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1107 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1110 if (check_used (attr
, name
, where
))
1114 return check_conflict (attr
, name
, where
);
1119 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1122 attr
->in_namelist
= 1;
1123 return check_conflict (attr
, name
, where
);
1128 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1131 if (check_used (attr
, name
, where
))
1135 return check_conflict (attr
, name
, where
);
1140 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1143 if (check_used (attr
, NULL
, where
))
1146 attr
->elemental
= 1;
1147 return check_conflict (attr
, NULL
, where
);
1152 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1155 if (check_used (attr
, NULL
, where
))
1159 return check_conflict (attr
, NULL
, where
);
1164 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1167 if (check_used (attr
, NULL
, where
))
1170 attr
->recursive
= 1;
1171 return check_conflict (attr
, NULL
, where
);
1176 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1179 if (check_used (attr
, name
, where
))
1184 duplicate_attr ("ENTRY", where
);
1189 return check_conflict (attr
, name
, where
);
1194 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1197 if (attr
->flavor
!= FL_PROCEDURE
1198 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1202 return check_conflict (attr
, name
, where
);
1207 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1210 if (attr
->flavor
!= FL_PROCEDURE
1211 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1214 attr
->subroutine
= 1;
1215 return check_conflict (attr
, name
, where
);
1220 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1223 if (attr
->flavor
!= FL_PROCEDURE
1224 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1228 return check_conflict (attr
, name
, where
);
1233 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1236 if (check_used (attr
, NULL
, where
))
1239 if (attr
->flavor
!= FL_PROCEDURE
1240 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1243 if (attr
->procedure
)
1245 duplicate_attr ("PROCEDURE", where
);
1249 attr
->procedure
= 1;
1251 return check_conflict (attr
, NULL
, where
);
1255 /* Flavors are special because some flavors are not what Fortran
1256 considers attributes and can be reaffirmed multiple times. */
1259 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1263 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1264 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1265 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1268 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1271 if (attr
->flavor
!= FL_UNKNOWN
)
1274 where
= &gfc_current_locus
;
1277 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1278 gfc_code2string (flavors
, attr
->flavor
), name
,
1279 gfc_code2string (flavors
, f
), where
);
1281 gfc_error ("%s attribute conflicts with %s attribute at %L",
1282 gfc_code2string (flavors
, attr
->flavor
),
1283 gfc_code2string (flavors
, f
), where
);
1290 return check_conflict (attr
, name
, where
);
1295 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1296 const char *name
, locus
*where
)
1299 if (check_used (attr
, name
, where
))
1302 if (attr
->flavor
!= FL_PROCEDURE
1303 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1307 where
= &gfc_current_locus
;
1309 if (attr
->proc
!= PROC_UNKNOWN
)
1311 gfc_error ("%s procedure at %L is already declared as %s procedure",
1312 gfc_code2string (procedures
, t
), where
,
1313 gfc_code2string (procedures
, attr
->proc
));
1320 /* Statement functions are always scalar and functions. */
1321 if (t
== PROC_ST_FUNCTION
1322 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1323 || attr
->dimension
))
1326 return check_conflict (attr
, name
, where
);
1331 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1334 if (check_used (attr
, NULL
, where
))
1337 if (attr
->intent
== INTENT_UNKNOWN
)
1339 attr
->intent
= intent
;
1340 return check_conflict (attr
, NULL
, where
);
1344 where
= &gfc_current_locus
;
1346 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1347 gfc_intent_string (attr
->intent
),
1348 gfc_intent_string (intent
), where
);
1354 /* No checks for use-association in public and private statements. */
1357 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1358 const char *name
, locus
*where
)
1361 if (attr
->access
== ACCESS_UNKNOWN
)
1363 attr
->access
= access
;
1364 return check_conflict (attr
, name
, where
);
1368 where
= &gfc_current_locus
;
1369 gfc_error ("ACCESS specification at %L was already specified", where
);
1375 /* Set the is_bind_c field for the given symbol_attribute. */
1378 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1379 int is_proc_lang_bind_spec
)
1382 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1383 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1384 "variables or common blocks", where
);
1385 else if (attr
->is_bind_c
)
1386 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1388 attr
->is_bind_c
= 1;
1391 where
= &gfc_current_locus
;
1393 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1397 return check_conflict (attr
, name
, where
);
1402 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1403 gfc_formal_arglist
* formal
, locus
*where
)
1406 if (check_used (&sym
->attr
, sym
->name
, where
))
1410 where
= &gfc_current_locus
;
1412 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1413 && sym
->attr
.if_source
!= IFSRC_DECL
)
1415 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1420 sym
->formal
= formal
;
1421 sym
->attr
.if_source
= source
;
1427 /* Add a type to a symbol. */
1430 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1435 where
= &gfc_current_locus
;
1437 if (sym
->ts
.type
!= BT_UNKNOWN
)
1439 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1440 if (!(sym
->ts
.type
== ts
->type
1441 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1442 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1445 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1448 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1449 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1453 flavor
= sym
->attr
.flavor
;
1455 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1456 || flavor
== FL_LABEL
1457 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1458 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1460 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1469 /* Clears all attributes. */
1472 gfc_clear_attr (symbol_attribute
*attr
)
1474 memset (attr
, 0, sizeof (symbol_attribute
));
1478 /* Check for missing attributes in the new symbol. Currently does
1479 nothing, but it's not clear that it is unnecessary yet. */
1482 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1483 locus
*where ATTRIBUTE_UNUSED
)
1490 /* Copy an attribute to a symbol attribute, bit by bit. Some
1491 attributes have a lot of side-effects but cannot be present given
1492 where we are called from, so we ignore some bits. */
1495 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1497 int is_proc_lang_bind_spec
;
1499 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1502 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1504 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1506 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1508 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1510 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1512 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1514 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1516 if (src
->threadprivate
1517 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1519 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1521 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1523 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1528 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1531 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1534 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1536 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1538 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1541 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1543 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1545 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1547 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1550 if (src
->flavor
!= FL_UNKNOWN
1551 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1554 if (src
->intent
!= INTENT_UNKNOWN
1555 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1558 if (src
->access
!= ACCESS_UNKNOWN
1559 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1562 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1565 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1567 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1570 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1572 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1576 if (src
->is_c_interop
)
1577 dest
->is_c_interop
= 1;
1581 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1583 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1593 /************** Component name management ************/
1595 /* Component names of a derived type form their own little namespaces
1596 that are separate from all other spaces. The space is composed of
1597 a singly linked list of gfc_component structures whose head is
1598 located in the parent symbol. */
1601 /* Add a component name to a symbol. The call fails if the name is
1602 already present. On success, the component pointer is modified to
1603 point to the additional component structure. */
1606 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1607 gfc_component
**component
)
1609 gfc_component
*p
, *tail
;
1613 for (p
= sym
->components
; p
; p
= p
->next
)
1615 if (strcmp (p
->name
, name
) == 0)
1617 gfc_error ("Component '%s' at %C already declared at %L",
1625 /* Allocate a new component. */
1626 p
= gfc_get_component ();
1629 sym
->components
= p
;
1633 p
->name
= gfc_get_string (name
);
1634 p
->loc
= gfc_current_locus
;
1641 /* Recursive function to switch derived types of all symbol in a
1645 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1653 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1654 sym
->ts
.derived
= to
;
1656 switch_types (st
->left
, from
, to
);
1657 switch_types (st
->right
, from
, to
);
1661 /* This subroutine is called when a derived type is used in order to
1662 make the final determination about which version to use. The
1663 standard requires that a type be defined before it is 'used', but
1664 such types can appear in IMPLICIT statements before the actual
1665 definition. 'Using' in this context means declaring a variable to
1666 be that type or using the type constructor.
1668 If a type is used and the components haven't been defined, then we
1669 have to have a derived type in a parent unit. We find the node in
1670 the other namespace and point the symtree node in this namespace to
1671 that node. Further reference to this name point to the correct
1672 node. If we can't find the node in a parent namespace, then we have
1675 This subroutine takes a pointer to a symbol node and returns a
1676 pointer to the translated node or NULL for an error. Usually there
1677 is no translation and we return the node we were passed. */
1680 gfc_use_derived (gfc_symbol
*sym
)
1687 if (sym
->components
!= NULL
)
1688 return sym
; /* Already defined. */
1690 if (sym
->ns
->parent
== NULL
)
1693 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1695 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1699 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1702 /* Get rid of symbol sym, translating all references to s. */
1703 for (i
= 0; i
< GFC_LETTERS
; i
++)
1705 t
= &sym
->ns
->default_type
[i
];
1706 if (t
->derived
== sym
)
1710 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1715 /* Unlink from list of modified symbols. */
1716 gfc_commit_symbol (sym
);
1718 switch_types (sym
->ns
->sym_root
, sym
, s
);
1720 /* TODO: Also have to replace sym -> s in other lists like
1721 namelists, common lists and interface lists. */
1722 gfc_free_symbol (sym
);
1727 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1733 /* Given a derived type node and a component name, try to locate the
1734 component structure. Returns the NULL pointer if the component is
1735 not found or the components are private. */
1738 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1745 sym
= gfc_use_derived (sym
);
1750 for (p
= sym
->components
; p
; p
= p
->next
)
1751 if (strcmp (p
->name
, name
) == 0)
1755 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1759 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1760 || p
->access
== ACCESS_PRIVATE
))
1762 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1772 /* Given a symbol, free all of the component structures and everything
1776 free_components (gfc_component
*p
)
1784 gfc_free_array_spec (p
->as
);
1785 gfc_free_expr (p
->initializer
);
1792 /* Set component attributes from a standard symbol attribute structure. */
1795 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1798 c
->dimension
= attr
->dimension
;
1799 c
->pointer
= attr
->pointer
;
1800 c
->allocatable
= attr
->allocatable
;
1801 c
->access
= attr
->access
;
1805 /* Get a standard symbol attribute structure given the component
1809 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1812 gfc_clear_attr (attr
);
1813 attr
->dimension
= c
->dimension
;
1814 attr
->pointer
= c
->pointer
;
1815 attr
->allocatable
= c
->allocatable
;
1816 attr
->access
= c
->access
;
1820 /******************** Statement label management ********************/
1822 /* Comparison function for statement labels, used for managing the
1826 compare_st_labels (void *a1
, void *b1
)
1828 int a
= ((gfc_st_label
*) a1
)->value
;
1829 int b
= ((gfc_st_label
*) b1
)->value
;
1835 /* Free a single gfc_st_label structure, making sure the tree is not
1836 messed up. This function is called only when some parse error
1840 gfc_free_st_label (gfc_st_label
*label
)
1846 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1848 if (label
->format
!= NULL
)
1849 gfc_free_expr (label
->format
);
1855 /* Free a whole tree of gfc_st_label structures. */
1858 free_st_labels (gfc_st_label
*label
)
1864 free_st_labels (label
->left
);
1865 free_st_labels (label
->right
);
1867 if (label
->format
!= NULL
)
1868 gfc_free_expr (label
->format
);
1873 /* Given a label number, search for and return a pointer to the label
1874 structure, creating it if it does not exist. */
1877 gfc_get_st_label (int labelno
)
1881 /* First see if the label is already in this namespace. */
1882 lp
= gfc_current_ns
->st_labels
;
1885 if (lp
->value
== labelno
)
1888 if (lp
->value
< labelno
)
1894 lp
= gfc_getmem (sizeof (gfc_st_label
));
1896 lp
->value
= labelno
;
1897 lp
->defined
= ST_LABEL_UNKNOWN
;
1898 lp
->referenced
= ST_LABEL_UNKNOWN
;
1900 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1906 /* Called when a statement with a statement label is about to be
1907 accepted. We add the label to the list of the current namespace,
1908 making sure it hasn't been defined previously and referenced
1912 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1916 labelno
= lp
->value
;
1918 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1919 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1920 &lp
->where
, label_locus
);
1923 lp
->where
= *label_locus
;
1927 case ST_LABEL_FORMAT
:
1928 if (lp
->referenced
== ST_LABEL_TARGET
)
1929 gfc_error ("Label %d at %C already referenced as branch target",
1932 lp
->defined
= ST_LABEL_FORMAT
;
1936 case ST_LABEL_TARGET
:
1937 if (lp
->referenced
== ST_LABEL_FORMAT
)
1938 gfc_error ("Label %d at %C already referenced as a format label",
1941 lp
->defined
= ST_LABEL_TARGET
;
1946 lp
->defined
= ST_LABEL_BAD_TARGET
;
1947 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1953 /* Reference a label. Given a label and its type, see if that
1954 reference is consistent with what is known about that label,
1955 updating the unknown state. Returns FAILURE if something goes
1959 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1961 gfc_sl_type label_type
;
1968 labelno
= lp
->value
;
1970 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1971 label_type
= lp
->defined
;
1974 label_type
= lp
->referenced
;
1975 lp
->where
= gfc_current_locus
;
1978 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1980 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1985 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1986 && type
== ST_LABEL_FORMAT
)
1988 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1993 lp
->referenced
= type
;
2001 /*******A helper function for creating new expressions*************/
2005 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2008 lval
= gfc_get_expr ();
2009 lval
->expr_type
= EXPR_VARIABLE
;
2010 lval
->where
= sym
->declared_at
;
2012 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2014 /* It will always be a full array. */
2015 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2018 lval
->ref
= gfc_get_ref ();
2019 lval
->ref
->type
= REF_ARRAY
;
2020 lval
->ref
->u
.ar
.type
= AR_FULL
;
2021 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2022 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2023 lval
->ref
->u
.ar
.as
= sym
->as
;
2030 /************** Symbol table management subroutines ****************/
2032 /* Basic details: Fortran 95 requires a potentially unlimited number
2033 of distinct namespaces when compiling a program unit. This case
2034 occurs during a compilation of internal subprograms because all of
2035 the internal subprograms must be read before we can start
2036 generating code for the host.
2038 Given the tricky nature of the Fortran grammar, we must be able to
2039 undo changes made to a symbol table if the current interpretation
2040 of a statement is found to be incorrect. Whenever a symbol is
2041 looked up, we make a copy of it and link to it. All of these
2042 symbols are kept in a singly linked list so that we can commit or
2043 undo the changes at a later time.
2045 A symtree may point to a symbol node outside of its namespace. In
2046 this case, that symbol has been used as a host associated variable
2047 at some previous time. */
2049 /* Allocate a new namespace structure. Copies the implicit types from
2050 PARENT if PARENT_TYPES is set. */
2053 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2057 gfc_intrinsic_op in
;
2060 ns
= gfc_getmem (sizeof (gfc_namespace
));
2061 ns
->sym_root
= NULL
;
2062 ns
->uop_root
= NULL
;
2063 ns
->default_access
= ACCESS_UNKNOWN
;
2064 ns
->parent
= parent
;
2066 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2067 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2069 /* Initialize default implicit types. */
2070 for (i
= 'a'; i
<= 'z'; i
++)
2072 ns
->set_flag
[i
- 'a'] = 0;
2073 ts
= &ns
->default_type
[i
- 'a'];
2075 if (parent_types
&& ns
->parent
!= NULL
)
2077 /* Copy parent settings. */
2078 *ts
= ns
->parent
->default_type
[i
- 'a'];
2082 if (gfc_option
.flag_implicit_none
!= 0)
2088 if ('i' <= i
&& i
<= 'n')
2090 ts
->type
= BT_INTEGER
;
2091 ts
->kind
= gfc_default_integer_kind
;
2096 ts
->kind
= gfc_default_real_kind
;
2106 /* Comparison function for symtree nodes. */
2109 compare_symtree (void *_st1
, void *_st2
)
2111 gfc_symtree
*st1
, *st2
;
2113 st1
= (gfc_symtree
*) _st1
;
2114 st2
= (gfc_symtree
*) _st2
;
2116 return strcmp (st1
->name
, st2
->name
);
2120 /* Allocate a new symtree node and associate it with the new symbol. */
2123 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2127 st
= gfc_getmem (sizeof (gfc_symtree
));
2128 st
->name
= gfc_get_string (name
);
2130 gfc_insert_bbt (root
, st
, compare_symtree
);
2135 /* Delete a symbol from the tree. Does not free the symbol itself! */
2138 delete_symtree (gfc_symtree
**root
, const char *name
)
2140 gfc_symtree st
, *st0
;
2142 st0
= gfc_find_symtree (*root
, name
);
2144 st
.name
= gfc_get_string (name
);
2145 gfc_delete_bbt (root
, &st
, compare_symtree
);
2151 /* Given a root symtree node and a name, try to find the symbol within
2152 the namespace. Returns NULL if the symbol is not found. */
2155 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2161 c
= strcmp (name
, st
->name
);
2165 st
= (c
< 0) ? st
->left
: st
->right
;
2172 /* Return a symtree node with a name that is guaranteed to be unique
2173 within the namespace and corresponds to an illegal fortran name. */
2176 gfc_get_unique_symtree (gfc_namespace
*ns
)
2178 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2179 static int serial
= 0;
2181 sprintf (name
, "@%d", serial
++);
2182 return gfc_new_symtree (&ns
->sym_root
, name
);
2186 /* Given a name find a user operator node, creating it if it doesn't
2187 exist. These are much simpler than symbols because they can't be
2188 ambiguous with one another. */
2191 gfc_get_uop (const char *name
)
2196 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2200 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2202 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2203 uop
->name
= gfc_get_string (name
);
2204 uop
->access
= ACCESS_UNKNOWN
;
2205 uop
->ns
= gfc_current_ns
;
2211 /* Given a name find the user operator node. Returns NULL if it does
2215 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2220 ns
= gfc_current_ns
;
2222 st
= gfc_find_symtree (ns
->uop_root
, name
);
2223 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2227 /* Remove a gfc_symbol structure and everything it points to. */
2230 gfc_free_symbol (gfc_symbol
*sym
)
2236 gfc_free_array_spec (sym
->as
);
2238 free_components (sym
->components
);
2240 gfc_free_expr (sym
->value
);
2242 gfc_free_namelist (sym
->namelist
);
2244 gfc_free_namespace (sym
->formal_ns
);
2246 if (!sym
->attr
.generic_copy
)
2247 gfc_free_interface (sym
->generic
);
2249 gfc_free_formal_arglist (sym
->formal
);
2255 /* Allocate and initialize a new symbol node. */
2258 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2262 p
= gfc_getmem (sizeof (gfc_symbol
));
2264 gfc_clear_ts (&p
->ts
);
2265 gfc_clear_attr (&p
->attr
);
2268 p
->declared_at
= gfc_current_locus
;
2270 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2271 gfc_internal_error ("new_symbol(): Symbol name too long");
2273 p
->name
= gfc_get_string (name
);
2275 /* Make sure flags for symbol being C bound are clear initially. */
2276 p
->attr
.is_bind_c
= 0;
2277 p
->attr
.is_iso_c
= 0;
2278 /* Make sure the binding label field has a Nul char to start. */
2279 p
->binding_label
[0] = '\0';
2281 /* Clear the ptrs we may need. */
2282 p
->common_block
= NULL
;
2288 /* Generate an error if a symbol is ambiguous. */
2291 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2294 if (st
->n
.sym
->module
)
2295 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2296 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2298 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2299 "from current program unit", name
, st
->n
.sym
->name
);
2303 /* Search for a symtree starting in the current namespace, resorting to
2304 any parent namespaces if requested by a nonzero parent_flag.
2305 Returns nonzero if the name is ambiguous. */
2308 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2309 gfc_symtree
**result
)
2314 ns
= gfc_current_ns
;
2318 st
= gfc_find_symtree (ns
->sym_root
, name
);
2322 /* Ambiguous generic interfaces are permitted, as long
2323 as the specific interfaces are different. */
2324 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2326 ambiguous_symbol (name
, st
);
2345 /* Same, but returns the symbol instead. */
2348 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2349 gfc_symbol
**result
)
2354 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2359 *result
= st
->n
.sym
;
2365 /* Save symbol with the information necessary to back it out. */
2368 save_symbol_data (gfc_symbol
*sym
)
2371 if (sym
->new || sym
->old_symbol
!= NULL
)
2374 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2375 *(sym
->old_symbol
) = *sym
;
2377 sym
->tlink
= changed_syms
;
2382 /* Given a name, find a symbol, or create it if it does not exist yet
2383 in the current namespace. If the symbol is found we make sure that
2386 The integer return code indicates
2388 1 The symbol name was ambiguous
2389 2 The name meant to be established was already host associated.
2391 So if the return value is nonzero, then an error was issued. */
2394 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2399 /* This doesn't usually happen during resolution. */
2401 ns
= gfc_current_ns
;
2403 /* Try to find the symbol in ns. */
2404 st
= gfc_find_symtree (ns
->sym_root
, name
);
2408 /* If not there, create a new symbol. */
2409 p
= gfc_new_symbol (name
, ns
);
2411 /* Add to the list of tentative symbols. */
2412 p
->old_symbol
= NULL
;
2413 p
->tlink
= changed_syms
;
2418 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2425 /* Make sure the existing symbol is OK. Ambiguous
2426 generic interfaces are permitted, as long as the
2427 specific interfaces are different. */
2428 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2430 ambiguous_symbol (name
, st
);
2436 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2438 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2439 && (ns
->has_import_set
|| p
->attr
.imported
)))
2441 /* Symbol is from another namespace. */
2442 gfc_error ("Symbol '%s' at %C has already been host associated",
2449 /* Copy in case this symbol is changed. */
2450 save_symbol_data (p
);
2459 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2464 i
= gfc_get_sym_tree (name
, ns
, &st
);
2469 *result
= st
->n
.sym
;
2476 /* Subroutine that searches for a symbol, creating it if it doesn't
2477 exist, but tries to host-associate the symbol if possible. */
2480 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2485 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2488 save_symbol_data (st
->n
.sym
);
2493 if (gfc_current_ns
->parent
!= NULL
)
2495 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2506 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2511 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2516 i
= gfc_get_ha_sym_tree (name
, &st
);
2519 *result
= st
->n
.sym
;
2526 /* Return true if both symbols could refer to the same data object. Does
2527 not take account of aliasing due to equivalence statements. */
2530 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2532 /* Aliasing isn't possible if the symbols have different base types. */
2533 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2536 /* Pointers can point to other pointers, target objects and allocatable
2537 objects. Two allocatable objects cannot share the same storage. */
2538 if (lsym
->attr
.pointer
2539 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2541 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2543 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2550 /* Undoes all the changes made to symbols in the current statement.
2551 This subroutine is made simpler due to the fact that attributes are
2552 never removed once added. */
2555 gfc_undo_symbols (void)
2557 gfc_symbol
*p
, *q
, *old
;
2559 for (p
= changed_syms
; p
; p
= q
)
2565 /* Symbol was new. */
2566 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2570 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2572 gfc_free_symbol (p
);
2576 /* Restore previous state of symbol. Just copy simple stuff. */
2578 old
= p
->old_symbol
;
2580 p
->ts
.type
= old
->ts
.type
;
2581 p
->ts
.kind
= old
->ts
.kind
;
2583 p
->attr
= old
->attr
;
2585 if (p
->value
!= old
->value
)
2587 gfc_free_expr (old
->value
);
2591 if (p
->as
!= old
->as
)
2594 gfc_free_array_spec (p
->as
);
2598 p
->generic
= old
->generic
;
2599 p
->component_access
= old
->component_access
;
2601 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2603 gfc_free_namelist (p
->namelist
);
2608 if (p
->namelist_tail
!= old
->namelist_tail
)
2610 gfc_free_namelist (old
->namelist_tail
);
2611 old
->namelist_tail
->next
= NULL
;
2615 p
->namelist_tail
= old
->namelist_tail
;
2617 if (p
->formal
!= old
->formal
)
2619 gfc_free_formal_arglist (p
->formal
);
2620 p
->formal
= old
->formal
;
2623 gfc_free (p
->old_symbol
);
2624 p
->old_symbol
= NULL
;
2628 changed_syms
= NULL
;
2632 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2633 components of old_symbol that might need deallocation are the "allocatables"
2634 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2635 namelist_tail. In case these differ between old_symbol and sym, it's just
2636 because sym->namelist has gotten a few more items. */
2639 free_old_symbol (gfc_symbol
*sym
)
2642 if (sym
->old_symbol
== NULL
)
2645 if (sym
->old_symbol
->as
!= sym
->as
)
2646 gfc_free_array_spec (sym
->old_symbol
->as
);
2648 if (sym
->old_symbol
->value
!= sym
->value
)
2649 gfc_free_expr (sym
->old_symbol
->value
);
2651 if (sym
->old_symbol
->formal
!= sym
->formal
)
2652 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2654 gfc_free (sym
->old_symbol
);
2655 sym
->old_symbol
= NULL
;
2659 /* Makes the changes made in the current statement permanent-- gets
2660 rid of undo information. */
2663 gfc_commit_symbols (void)
2667 for (p
= changed_syms
; p
; p
= q
)
2673 free_old_symbol (p
);
2675 changed_syms
= NULL
;
2679 /* Makes the changes made in one symbol permanent -- gets rid of undo
2683 gfc_commit_symbol (gfc_symbol
*sym
)
2687 if (changed_syms
== sym
)
2688 changed_syms
= sym
->tlink
;
2691 for (p
= changed_syms
; p
; p
= p
->tlink
)
2692 if (p
->tlink
== sym
)
2694 p
->tlink
= sym
->tlink
;
2703 free_old_symbol (sym
);
2707 /* Recursive function that deletes an entire tree and all the common
2708 head structures it points to. */
2711 free_common_tree (gfc_symtree
* common_tree
)
2713 if (common_tree
== NULL
)
2716 free_common_tree (common_tree
->left
);
2717 free_common_tree (common_tree
->right
);
2719 gfc_free (common_tree
);
2723 /* Recursive function that deletes an entire tree and all the user
2724 operator nodes that it contains. */
2727 free_uop_tree (gfc_symtree
*uop_tree
)
2730 if (uop_tree
== NULL
)
2733 free_uop_tree (uop_tree
->left
);
2734 free_uop_tree (uop_tree
->right
);
2736 gfc_free_interface (uop_tree
->n
.uop
->operator);
2738 gfc_free (uop_tree
->n
.uop
);
2739 gfc_free (uop_tree
);
2743 /* Recursive function that deletes an entire tree and all the symbols
2744 that it contains. */
2747 free_sym_tree (gfc_symtree
*sym_tree
)
2752 if (sym_tree
== NULL
)
2755 free_sym_tree (sym_tree
->left
);
2756 free_sym_tree (sym_tree
->right
);
2758 sym
= sym_tree
->n
.sym
;
2762 gfc_internal_error ("free_sym_tree(): Negative refs");
2764 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2766 /* As formal_ns contains a reference to sym, delete formal_ns just
2767 before the deletion of sym. */
2768 ns
= sym
->formal_ns
;
2769 sym
->formal_ns
= NULL
;
2770 gfc_free_namespace (ns
);
2772 else if (sym
->refs
== 0)
2774 /* Go ahead and delete the symbol. */
2775 gfc_free_symbol (sym
);
2778 gfc_free (sym_tree
);
2782 /* Free the derived type list. */
2785 gfc_free_dt_list (void)
2787 gfc_dt_list
*dt
, *n
;
2789 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2795 gfc_derived_types
= NULL
;
2799 /* Free the gfc_equiv_info's. */
2802 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2806 gfc_free_equiv_infos (s
->next
);
2811 /* Free the gfc_equiv_lists. */
2814 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2818 gfc_free_equiv_lists (l
->next
);
2819 gfc_free_equiv_infos (l
->equiv
);
2824 /* Free a namespace structure and everything below it. Interface
2825 lists associated with intrinsic operators are not freed. These are
2826 taken care of when a specific name is freed. */
2829 gfc_free_namespace (gfc_namespace
*ns
)
2831 gfc_charlen
*cl
, *cl2
;
2832 gfc_namespace
*p
, *q
;
2841 gcc_assert (ns
->refs
== 0);
2843 gfc_free_statements (ns
->code
);
2845 free_sym_tree (ns
->sym_root
);
2846 free_uop_tree (ns
->uop_root
);
2847 free_common_tree (ns
->common_root
);
2849 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2852 gfc_free_expr (cl
->length
);
2856 free_st_labels (ns
->st_labels
);
2858 gfc_free_equiv (ns
->equiv
);
2859 gfc_free_equiv_lists (ns
->equiv_lists
);
2861 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2862 gfc_free_interface (ns
->operator[i
]);
2864 gfc_free_data (ns
->data
);
2868 /* Recursively free any contained namespaces. */
2873 gfc_free_namespace (q
);
2879 gfc_symbol_init_2 (void)
2882 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2887 gfc_symbol_done_2 (void)
2890 gfc_free_namespace (gfc_current_ns
);
2891 gfc_current_ns
= NULL
;
2892 gfc_free_dt_list ();
2896 /* Clear mark bits from symbol nodes associated with a symtree node. */
2899 clear_sym_mark (gfc_symtree
*st
)
2902 st
->n
.sym
->mark
= 0;
2906 /* Recursively traverse the symtree nodes. */
2909 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2915 gfc_traverse_symtree (st
->left
, func
);
2916 gfc_traverse_symtree (st
->right
, func
);
2921 /* Recursive namespace traversal function. */
2924 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2930 if (st
->n
.sym
->mark
== 0)
2931 (*func
) (st
->n
.sym
);
2932 st
->n
.sym
->mark
= 1;
2934 traverse_ns (st
->left
, func
);
2935 traverse_ns (st
->right
, func
);
2939 /* Call a given function for all symbols in the namespace. We take
2940 care that each gfc_symbol node is called exactly once. */
2943 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2946 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2948 traverse_ns (ns
->sym_root
, func
);
2952 /* Return TRUE when name is the name of an intrinsic type. */
2955 gfc_is_intrinsic_typename (const char *name
)
2957 if (strcmp (name
, "integer") == 0
2958 || strcmp (name
, "real") == 0
2959 || strcmp (name
, "character") == 0
2960 || strcmp (name
, "logical") == 0
2961 || strcmp (name
, "complex") == 0
2962 || strcmp (name
, "doubleprecision") == 0
2963 || strcmp (name
, "doublecomplex") == 0)
2970 /* Return TRUE if the symbol is an automatic variable. */
2973 gfc_is_var_automatic (gfc_symbol
*sym
)
2975 /* Pointer and allocatable variables are never automatic. */
2976 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2978 /* Check for arrays with non-constant size. */
2979 if (sym
->attr
.dimension
&& sym
->as
2980 && !gfc_is_compile_time_shape (sym
->as
))
2982 /* Check for non-constant length character variables. */
2983 if (sym
->ts
.type
== BT_CHARACTER
2985 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2990 /* Given a symbol, mark it as SAVEd if it is allowed. */
2993 save_symbol (gfc_symbol
*sym
)
2996 if (sym
->attr
.use_assoc
)
2999 if (sym
->attr
.in_common
3001 || sym
->attr
.flavor
!= FL_VARIABLE
)
3003 /* Automatic objects are not saved. */
3004 if (gfc_is_var_automatic (sym
))
3006 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3010 /* Mark those symbols which can be SAVEd as such. */
3013 gfc_save_all (gfc_namespace
*ns
)
3016 gfc_traverse_ns (ns
, save_symbol
);
3021 /* Make sure that no changes to symbols are pending. */
3024 gfc_symbol_state(void) {
3026 if (changed_syms
!= NULL
)
3027 gfc_internal_error("Symbol changes still pending!");
3032 /************** Global symbol handling ************/
3035 /* Search a tree for the global symbol. */
3038 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3047 c
= strcmp (name
, symbol
->name
);
3051 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3058 /* Compare two global symbols. Used for managing the BB tree. */
3061 gsym_compare (void *_s1
, void *_s2
)
3063 gfc_gsymbol
*s1
, *s2
;
3065 s1
= (gfc_gsymbol
*) _s1
;
3066 s2
= (gfc_gsymbol
*) _s2
;
3067 return strcmp (s1
->name
, s2
->name
);
3071 /* Get a global symbol, creating it if it doesn't exist. */
3074 gfc_get_gsymbol (const char *name
)
3078 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3082 s
= gfc_getmem (sizeof (gfc_gsymbol
));
3083 s
->type
= GSYM_UNKNOWN
;
3084 s
->name
= gfc_get_string (name
);
3086 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3093 get_iso_c_binding_dt (int sym_id
)
3095 gfc_dt_list
*dt_list
;
3097 dt_list
= gfc_derived_types
;
3099 /* Loop through the derived types in the name list, searching for
3100 the desired symbol from iso_c_binding. Search the parent namespaces
3101 if necessary and requested to (parent_flag). */
3102 while (dt_list
!= NULL
)
3104 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3105 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3106 return dt_list
->derived
;
3108 dt_list
= dt_list
->next
;
3115 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3116 with C. This is necessary for any derived type that is BIND(C) and for
3117 derived types that are parameters to functions that are BIND(C). All
3118 fields of the derived type are required to be interoperable, and are tested
3119 for such. If an error occurs, the errors are reported here, allowing for
3120 multiple errors to be handled for a single derived type. */
3123 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3125 gfc_component
*curr_comp
= NULL
;
3126 try is_c_interop
= FAILURE
;
3127 try retval
= SUCCESS
;
3129 if (derived_sym
== NULL
)
3130 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3131 "unexpectedly NULL");
3133 /* If we've already looked at this derived symbol, do not look at it again
3134 so we don't repeat warnings/errors. */
3135 if (derived_sym
->ts
.is_c_interop
)
3138 /* The derived type must have the BIND attribute to be interoperable
3139 J3/04-007, Section 15.2.3. */
3140 if (derived_sym
->attr
.is_bind_c
!= 1)
3142 derived_sym
->ts
.is_c_interop
= 0;
3143 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3144 "attribute to be C interoperable", derived_sym
->name
,
3145 &(derived_sym
->declared_at
));
3149 curr_comp
= derived_sym
->components
;
3151 /* TODO: is this really an error? */
3152 if (curr_comp
== NULL
)
3154 gfc_error ("Derived type '%s' at %L is empty",
3155 derived_sym
->name
, &(derived_sym
->declared_at
));
3159 /* Initialize the derived type as being C interoperable.
3160 If we find an error in the components, this will be set false. */
3161 derived_sym
->ts
.is_c_interop
= 1;
3163 /* Loop through the list of components to verify that the kind of
3164 each is a C interoperable type. */
3167 /* The components cannot be pointers (fortran sense).
3168 J3/04-007, Section 15.2.3, C1505. */
3169 if (curr_comp
->pointer
!= 0)
3171 gfc_error ("Component '%s' at %L cannot have the "
3172 "POINTER attribute because it is a member "
3173 "of the BIND(C) derived type '%s' at %L",
3174 curr_comp
->name
, &(curr_comp
->loc
),
3175 derived_sym
->name
, &(derived_sym
->declared_at
));
3179 /* The components cannot be allocatable.
3180 J3/04-007, Section 15.2.3, C1505. */
3181 if (curr_comp
->allocatable
!= 0)
3183 gfc_error ("Component '%s' at %L cannot have the "
3184 "ALLOCATABLE attribute because it is a member "
3185 "of the BIND(C) derived type '%s' at %L",
3186 curr_comp
->name
, &(curr_comp
->loc
),
3187 derived_sym
->name
, &(derived_sym
->declared_at
));
3191 /* BIND(C) derived types must have interoperable components. */
3192 if (curr_comp
->ts
.type
== BT_DERIVED
3193 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3194 && curr_comp
->ts
.derived
!= derived_sym
)
3196 /* This should be allowed; the draft says a derived-type can not
3197 have type parameters if it is has the BIND attribute. Type
3198 parameters seem to be for making parameterized derived types.
3199 There's no need to verify the type if it is c_ptr/c_funptr. */
3200 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3204 /* Grab the typespec for the given component and test the kind. */
3205 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3208 if (is_c_interop
!= SUCCESS
)
3210 /* Report warning and continue since not fatal. The
3211 draft does specify a constraint that requires all fields
3212 to interoperate, but if the user says real(4), etc., it
3213 may interoperate with *something* in C, but the compiler
3214 most likely won't know exactly what. Further, it may not
3215 interoperate with the same data type(s) in C if the user
3216 recompiles with different flags (e.g., -m32 and -m64 on
3217 x86_64 and using integer(4) to claim interop with a
3219 if (derived_sym
->attr
.is_bind_c
== 1)
3220 /* If the derived type is bind(c), all fields must be
3222 gfc_warning ("Component '%s' in derived type '%s' at %L "
3223 "may not be C interoperable, even though "
3224 "derived type '%s' is BIND(C)",
3225 curr_comp
->name
, derived_sym
->name
,
3226 &(curr_comp
->loc
), derived_sym
->name
);
3228 /* If derived type is param to bind(c) routine, or to one
3229 of the iso_c_binding procs, it must be interoperable, so
3230 all fields must interop too. */
3231 gfc_warning ("Component '%s' in derived type '%s' at %L "
3232 "may not be C interoperable",
3233 curr_comp
->name
, derived_sym
->name
,
3238 curr_comp
= curr_comp
->next
;
3239 } while (curr_comp
!= NULL
);
3242 /* Make sure we don't have conflicts with the attributes. */
3243 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3245 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3246 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3247 &(derived_sym
->declared_at
));
3251 if (derived_sym
->attr
.sequence
!= 0)
3253 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3254 "attribute because it is BIND(C)", derived_sym
->name
,
3255 &(derived_sym
->declared_at
));
3259 /* Mark the derived type as not being C interoperable if we found an
3260 error. If there were only warnings, proceed with the assumption
3261 it's interoperable. */
3262 if (retval
== FAILURE
)
3263 derived_sym
->ts
.is_c_interop
= 0;
3269 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3272 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3273 const char *module_name
)
3275 gfc_symtree
*tmp_symtree
;
3276 gfc_symbol
*tmp_sym
;
3278 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3280 if (tmp_symtree
!= NULL
)
3281 tmp_sym
= tmp_symtree
->n
.sym
;
3285 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3286 "create symbol for %s", ptr_name
);
3289 /* Set up the symbol's important fields. Save attr required so we can
3290 initialize the ptr to NULL. */
3291 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3292 tmp_sym
->ts
.is_c_interop
= 1;
3293 tmp_sym
->attr
.is_c_interop
= 1;
3294 tmp_sym
->ts
.is_iso_c
= 1;
3295 tmp_sym
->ts
.type
= BT_DERIVED
;
3297 /* The c_ptr and c_funptr derived types will provide the
3298 definition for c_null_ptr and c_null_funptr, respectively. */
3299 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3300 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3302 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3303 if (tmp_sym
->ts
.derived
== NULL
)
3305 /* This can occur if the user forgot to declare c_ptr or
3306 c_funptr and they're trying to use one of the procedures
3307 that has arg(s) of the missing type. In this case, a
3308 regular version of the thing should have been put in the
3310 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3311 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3312 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3313 ? "_gfortran_iso_c_binding_c_ptr"
3314 : "_gfortran_iso_c_binding_c_funptr"));
3316 tmp_sym
->ts
.derived
=
3317 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3318 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3321 /* Module name is some mangled version of iso_c_binding. */
3322 tmp_sym
->module
= gfc_get_string (module_name
);
3324 /* Say it's from the iso_c_binding module. */
3325 tmp_sym
->attr
.is_iso_c
= 1;
3327 tmp_sym
->attr
.use_assoc
= 1;
3328 tmp_sym
->attr
.is_bind_c
= 1;
3329 /* Set the binding_label. */
3330 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3332 /* Set the c_address field of c_null_ptr and c_null_funptr to
3333 the value of NULL. */
3334 tmp_sym
->value
= gfc_get_expr ();
3335 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3336 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3337 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3338 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3339 /* This line will initialize the c_null_ptr/c_null_funptr
3340 c_address field to NULL. */
3341 tmp_sym
->value
->value
.constructor
->expr
= gfc_int_expr (0);
3342 /* Must declare c_null_ptr and c_null_funptr as having the
3343 PARAMETER attribute so they can be used in init expressions. */
3344 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3350 /* Add a formal argument, gfc_formal_arglist, to the
3351 end of the given list of arguments. Set the reference to the
3352 provided symbol, param_sym, in the argument. */
3355 add_formal_arg (gfc_formal_arglist
**head
,
3356 gfc_formal_arglist
**tail
,
3357 gfc_formal_arglist
*formal_arg
,
3358 gfc_symbol
*param_sym
)
3360 /* Put in list, either as first arg or at the tail (curr arg). */
3362 *head
= *tail
= formal_arg
;
3365 (*tail
)->next
= formal_arg
;
3366 (*tail
) = formal_arg
;
3369 (*tail
)->sym
= param_sym
;
3370 (*tail
)->next
= NULL
;
3376 /* Generates a symbol representing the CPTR argument to an
3377 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3378 CPTR and add it to the provided argument list. */
3381 gen_cptr_param (gfc_formal_arglist
**head
,
3382 gfc_formal_arglist
**tail
,
3383 const char *module_name
,
3384 gfc_namespace
*ns
, const char *c_ptr_name
,
3387 gfc_symbol
*param_sym
= NULL
;
3388 gfc_symbol
*c_ptr_sym
= NULL
;
3389 gfc_symtree
*param_symtree
= NULL
;
3390 gfc_formal_arglist
*formal_arg
= NULL
;
3391 const char *c_ptr_in
;
3392 const char *c_ptr_type
= NULL
;
3394 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3395 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3397 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3399 if(c_ptr_name
== NULL
)
3400 c_ptr_in
= "gfc_cptr__";
3402 c_ptr_in
= c_ptr_name
;
3403 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3404 if (param_symtree
!= NULL
)
3405 param_sym
= param_symtree
->n
.sym
;
3407 gfc_internal_error ("gen_cptr_param(): Unable to "
3408 "create symbol for %s", c_ptr_in
);
3410 /* Set up the appropriate fields for the new c_ptr param sym. */
3412 param_sym
->attr
.flavor
= FL_DERIVED
;
3413 param_sym
->ts
.type
= BT_DERIVED
;
3414 param_sym
->attr
.intent
= INTENT_IN
;
3415 param_sym
->attr
.dummy
= 1;
3417 /* This will pass the ptr to the iso_c routines as a (void *). */
3418 param_sym
->attr
.value
= 1;
3419 param_sym
->attr
.use_assoc
= 1;
3421 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3423 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3424 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3426 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3427 if (c_ptr_sym
== NULL
)
3429 /* This can happen if the user did not define c_ptr but they are
3430 trying to use one of the iso_c_binding functions that need it. */
3431 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3432 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3433 (const char *)c_ptr_type
);
3435 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3436 (const char *)c_ptr_type
);
3438 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3441 param_sym
->ts
.derived
= c_ptr_sym
;
3442 param_sym
->module
= gfc_get_string (module_name
);
3444 /* Make new formal arg. */
3445 formal_arg
= gfc_get_formal_arglist ();
3446 /* Add arg to list of formal args (the CPTR arg). */
3447 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3451 /* Generates a symbol representing the FPTR argument to an
3452 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3453 FPTR and add it to the provided argument list. */
3456 gen_fptr_param (gfc_formal_arglist
**head
,
3457 gfc_formal_arglist
**tail
,
3458 const char *module_name
,
3459 gfc_namespace
*ns
, const char *f_ptr_name
)
3461 gfc_symbol
*param_sym
= NULL
;
3462 gfc_symtree
*param_symtree
= NULL
;
3463 gfc_formal_arglist
*formal_arg
= NULL
;
3464 const char *f_ptr_out
= "gfc_fptr__";
3466 if (f_ptr_name
!= NULL
)
3467 f_ptr_out
= f_ptr_name
;
3469 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3470 if (param_symtree
!= NULL
)
3471 param_sym
= param_symtree
->n
.sym
;
3473 gfc_internal_error ("generateFPtrParam(): Unable to "
3474 "create symbol for %s", f_ptr_out
);
3476 /* Set up the necessary fields for the fptr output param sym. */
3478 param_sym
->attr
.pointer
= 1;
3479 param_sym
->attr
.dummy
= 1;
3480 param_sym
->attr
.use_assoc
= 1;
3482 /* ISO C Binding type to allow any pointer type as actual param. */
3483 param_sym
->ts
.type
= BT_VOID
;
3484 param_sym
->module
= gfc_get_string (module_name
);
3487 formal_arg
= gfc_get_formal_arglist ();
3488 /* Add arg to list of formal args. */
3489 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3493 /* Generates a symbol representing the optional SHAPE argument for the
3494 iso_c_binding c_f_pointer() procedure. Also, create a
3495 gfc_formal_arglist for the SHAPE and add it to the provided
3499 gen_shape_param (gfc_formal_arglist
**head
,
3500 gfc_formal_arglist
**tail
,
3501 const char *module_name
,
3502 gfc_namespace
*ns
, const char *shape_param_name
)
3504 gfc_symbol
*param_sym
= NULL
;
3505 gfc_symtree
*param_symtree
= NULL
;
3506 gfc_formal_arglist
*formal_arg
= NULL
;
3507 const char *shape_param
= "gfc_shape_array__";
3510 if (shape_param_name
!= NULL
)
3511 shape_param
= shape_param_name
;
3513 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3514 if (param_symtree
!= NULL
)
3515 param_sym
= param_symtree
->n
.sym
;
3517 gfc_internal_error ("generateShapeParam(): Unable to "
3518 "create symbol for %s", shape_param
);
3520 /* Set up the necessary fields for the shape input param sym. */
3522 param_sym
->attr
.dummy
= 1;
3523 param_sym
->attr
.use_assoc
= 1;
3525 /* Integer array, rank 1, describing the shape of the object. Make it's
3526 type BT_VOID initially so we can accept any type/kind combination of
3527 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3528 of BT_INTEGER type. */
3529 param_sym
->ts
.type
= BT_VOID
;
3531 /* Initialize the kind to default integer. However, it will be overridden
3532 during resolution to match the kind of the SHAPE parameter given as
3533 the actual argument (to allow for any valid integer kind). */
3534 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3535 param_sym
->as
= gfc_get_array_spec ();
3537 /* Clear out the dimension info for the array. */
3538 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3540 param_sym
->as
->lower
[i
] = NULL
;
3541 param_sym
->as
->upper
[i
] = NULL
;
3543 param_sym
->as
->rank
= 1;
3544 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3546 /* The extent is unknown until we get it. The length give us
3547 the rank the incoming pointer. */
3548 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3550 /* The arg is also optional; it is required iff the second arg
3551 (fptr) is to an array, otherwise, it's ignored. */
3552 param_sym
->attr
.optional
= 1;
3553 param_sym
->attr
.intent
= INTENT_IN
;
3554 param_sym
->attr
.dimension
= 1;
3555 param_sym
->module
= gfc_get_string (module_name
);
3558 formal_arg
= gfc_get_formal_arglist ();
3559 /* Add arg to list of formal args. */
3560 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3563 /* Add a procedure interface to the given symbol (i.e., store a
3564 reference to the list of formal arguments). */
3567 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3568 gfc_formal_arglist
*formal
)
3571 sym
->formal
= formal
;
3572 sym
->attr
.if_source
= source
;
3575 /* Copy the formal args from an existing symbol, src, into a new
3576 symbol, dest. New formal args are created, and the description of
3577 each arg is set according to the existing ones. This function is
3578 used when creating procedure declaration variables from a procedure
3579 declaration statement (see match_proc_decl()) to create the formal
3580 args based on the args of a given named interface. */
3582 void copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3584 gfc_formal_arglist
*head
= NULL
;
3585 gfc_formal_arglist
*tail
= NULL
;
3586 gfc_formal_arglist
*formal_arg
= NULL
;
3587 gfc_formal_arglist
*curr_arg
= NULL
;
3588 gfc_formal_arglist
*formal_prev
= NULL
;
3589 /* Save current namespace so we can change it for formal args. */
3590 gfc_namespace
*parent_ns
= gfc_current_ns
;
3592 /* Create a new namespace, which will be the formal ns (namespace
3593 of the formal args). */
3594 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3595 gfc_current_ns
->proc_name
= dest
;
3597 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3599 formal_arg
= gfc_get_formal_arglist ();
3600 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3602 /* May need to copy more info for the symbol. */
3603 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3604 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3606 /* If this isn't the first arg, set up the next ptr. For the
3607 last arg built, the formal_arg->next will never get set to
3608 anything other than NULL. */
3609 if (formal_prev
!= NULL
)
3610 formal_prev
->next
= formal_arg
;
3612 formal_arg
->next
= NULL
;
3614 formal_prev
= formal_arg
;
3616 /* Add arg to list of formal args. */
3617 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3620 /* Add the interface to the symbol. */
3621 add_proc_interface (dest
, IFSRC_DECL
, head
);
3623 /* Store the formal namespace information. */
3624 if (dest
->formal
!= NULL
)
3625 /* The current ns should be that for the dest proc. */
3626 dest
->formal_ns
= gfc_current_ns
;
3627 /* Restore the current namespace to what it was on entry. */
3628 gfc_current_ns
= parent_ns
;
3631 /* Builds the parameter list for the iso_c_binding procedure
3632 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3633 generic version of either the c_f_pointer or c_f_procpointer
3634 functions. The new_proc_sym represents a "resolved" version of the
3635 symbol. The functions are resolved to match the types of their
3636 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3637 something similar to c_f_pointer_i4 if the type of data object fptr
3638 pointed to was a default integer. The actual name of the resolved
3639 procedure symbol is further mangled with the module name, etc., but
3640 the idea holds true. */
3643 build_formal_args (gfc_symbol
*new_proc_sym
,
3644 gfc_symbol
*old_sym
, int add_optional_arg
)
3646 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3647 gfc_namespace
*parent_ns
= NULL
;
3649 parent_ns
= gfc_current_ns
;
3650 /* Create a new namespace, which will be the formal ns (namespace
3651 of the formal args). */
3652 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3653 gfc_current_ns
->proc_name
= new_proc_sym
;
3655 /* Generate the params. */
3656 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3657 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3659 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3660 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3661 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3662 gfc_current_ns
, "fptr");
3664 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3665 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3667 gen_shape_param (&head
, &tail
,
3668 (const char *) new_proc_sym
->module
,
3669 gfc_current_ns
, "shape");
3672 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3674 /* c_associated has one required arg and one optional; both
3676 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3677 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3678 if (add_optional_arg
)
3680 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3681 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3682 /* The last param is optional so mark it as such. */
3683 tail
->sym
->attr
.optional
= 1;
3687 /* Add the interface (store formal args to new_proc_sym). */
3688 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3690 /* Set up the formal_ns pointer to the one created for the
3691 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3692 new_proc_sym
->formal_ns
= gfc_current_ns
;
3694 gfc_current_ns
= parent_ns
;
3698 /* Generate the given set of C interoperable kind objects, or all
3699 interoperable kinds. This function will only be given kind objects
3700 for valid iso_c_binding defined types because this is verified when
3701 the 'use' statement is parsed. If the user gives an 'only' clause,
3702 the specific kinds are looked up; if they don't exist, an error is
3703 reported. If the user does not give an 'only' clause, all
3704 iso_c_binding symbols are generated. If a list of specific kinds
3705 is given, it must have a NULL in the first empty spot to mark the
3710 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3711 const char *local_name
)
3713 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3714 : c_interop_kinds_table
[s
].name
;
3715 gfc_symtree
*tmp_symtree
= NULL
;
3716 gfc_symbol
*tmp_sym
= NULL
;
3717 gfc_dt_list
**dt_list_ptr
= NULL
;
3718 gfc_component
*tmp_comp
= NULL
;
3719 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3722 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3724 /* Already exists in this scope so don't re-add it.
3725 TODO: we should probably check that it's really the same symbol. */
3726 if (tmp_symtree
!= NULL
)
3729 /* Create the sym tree in the current ns. */
3730 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3732 tmp_sym
= tmp_symtree
->n
.sym
;
3734 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3737 /* Say what module this symbol belongs to. */
3738 tmp_sym
->module
= gfc_get_string (mod_name
);
3739 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3740 tmp_sym
->intmod_sym_id
= s
;
3745 #define NAMED_INTCST(a,b,c) case a :
3746 #define NAMED_REALCST(a,b,c) case a :
3747 #define NAMED_CMPXCST(a,b,c) case a :
3748 #define NAMED_LOGCST(a,b,c) case a :
3749 #define NAMED_CHARKNDCST(a,b,c) case a :
3750 #include "iso-c-binding.def"
3752 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3754 /* Initialize an integer constant expression node. */
3755 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3756 tmp_sym
->ts
.type
= BT_INTEGER
;
3757 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3759 /* Mark this type as a C interoperable one. */
3760 tmp_sym
->ts
.is_c_interop
= 1;
3761 tmp_sym
->ts
.is_iso_c
= 1;
3762 tmp_sym
->value
->ts
.is_c_interop
= 1;
3763 tmp_sym
->value
->ts
.is_iso_c
= 1;
3764 tmp_sym
->attr
.is_c_interop
= 1;
3766 /* Tell what f90 type this c interop kind is valid. */
3767 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3769 /* Say it's from the iso_c_binding module. */
3770 tmp_sym
->attr
.is_iso_c
= 1;
3772 /* Make it use associated. */
3773 tmp_sym
->attr
.use_assoc
= 1;
3777 #define NAMED_CHARCST(a,b,c) case a :
3778 #include "iso-c-binding.def"
3780 /* Initialize an integer constant expression node for the
3781 length of the character. */
3782 tmp_sym
->value
= gfc_get_expr ();
3783 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3784 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3785 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3786 tmp_sym
->value
->where
= gfc_current_locus
;
3787 tmp_sym
->value
->ts
.is_c_interop
= 1;
3788 tmp_sym
->value
->ts
.is_iso_c
= 1;
3789 tmp_sym
->value
->value
.character
.length
= 1;
3790 tmp_sym
->value
->value
.character
.string
= gfc_getmem (2);
3791 tmp_sym
->value
->value
.character
.string
[0]
3792 = (char) c_interop_kinds_table
[s
].value
;
3793 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3795 /* May not need this in both attr and ts, but do need in
3796 attr for writing module file. */
3797 tmp_sym
->attr
.is_c_interop
= 1;
3799 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3800 tmp_sym
->ts
.type
= BT_CHARACTER
;
3802 /* Need to set it to the C_CHAR kind. */
3803 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3805 /* Mark this type as a C interoperable one. */
3806 tmp_sym
->ts
.is_c_interop
= 1;
3807 tmp_sym
->ts
.is_iso_c
= 1;
3809 /* Tell what f90 type this c interop kind is valid. */
3810 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3812 /* Say it's from the iso_c_binding module. */
3813 tmp_sym
->attr
.is_iso_c
= 1;
3815 /* Make it use associated. */
3816 tmp_sym
->attr
.use_assoc
= 1;
3819 case ISOCBINDING_PTR
:
3820 case ISOCBINDING_FUNPTR
:
3822 /* Initialize an integer constant expression node. */
3823 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3824 tmp_sym
->ts
.is_c_interop
= 1;
3825 tmp_sym
->attr
.is_c_interop
= 1;
3826 tmp_sym
->attr
.is_iso_c
= 1;
3827 tmp_sym
->ts
.is_iso_c
= 1;
3828 tmp_sym
->ts
.type
= BT_DERIVED
;
3830 /* A derived type must have the bind attribute to be
3831 interoperable (J3/04-007, Section 15.2.3), even though
3832 the binding label is not used. */
3833 tmp_sym
->attr
.is_bind_c
= 1;
3835 tmp_sym
->attr
.referenced
= 1;
3837 tmp_sym
->ts
.derived
= tmp_sym
;
3839 /* Add the symbol created for the derived type to the current ns. */
3840 dt_list_ptr
= &(gfc_derived_types
);
3841 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3842 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3844 /* There is already at least one derived type in the list, so append
3845 the one we're currently building for c_ptr or c_funptr. */
3846 if (*dt_list_ptr
!= NULL
)
3847 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3848 (*dt_list_ptr
) = gfc_get_dt_list ();
3849 (*dt_list_ptr
)->derived
= tmp_sym
;
3850 (*dt_list_ptr
)->next
= NULL
;
3852 /* Set up the component of the derived type, which will be
3853 an integer with kind equal to c_ptr_size. Mangle the name of
3854 the field for the c_address to prevent the curious user from
3855 trying to access it from Fortran. */
3856 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3857 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3858 if (tmp_comp
== NULL
)
3859 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3860 "create component for c_address");
3862 tmp_comp
->ts
.type
= BT_INTEGER
;
3864 /* Set this because the module will need to read/write this field. */
3865 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3867 /* The kinds for c_ptr and c_funptr are the same. */
3868 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3869 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3871 tmp_comp
->pointer
= 0;
3872 tmp_comp
->dimension
= 0;
3874 /* Mark the component as C interoperable. */
3875 tmp_comp
->ts
.is_c_interop
= 1;
3877 /* Make it use associated (iso_c_binding module). */
3878 tmp_sym
->attr
.use_assoc
= 1;
3881 case ISOCBINDING_NULL_PTR
:
3882 case ISOCBINDING_NULL_FUNPTR
:
3883 gen_special_c_interop_ptr (s
, name
, mod_name
);
3886 case ISOCBINDING_F_POINTER
:
3887 case ISOCBINDING_ASSOCIATED
:
3888 case ISOCBINDING_LOC
:
3889 case ISOCBINDING_FUNLOC
:
3890 case ISOCBINDING_F_PROCPOINTER
:
3892 tmp_sym
->attr
.proc
= PROC_MODULE
;
3894 /* Use the procedure's name as it is in the iso_c_binding module for
3895 setting the binding label in case the user renamed the symbol. */
3896 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3897 c_interop_kinds_table
[s
].name
);
3898 tmp_sym
->attr
.is_iso_c
= 1;
3899 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3900 tmp_sym
->attr
.subroutine
= 1;
3903 /* TODO! This needs to be finished more for the expr of the
3904 function or something!
3905 This may not need to be here, because trying to do c_loc
3907 if (s
== ISOCBINDING_ASSOCIATED
)
3909 tmp_sym
->attr
.function
= 1;
3910 tmp_sym
->ts
.type
= BT_LOGICAL
;
3911 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3912 tmp_sym
->result
= tmp_sym
;
3916 /* Here, we're taking the simple approach. We're defining
3917 c_loc as an external identifier so the compiler will put
3918 what we expect on the stack for the address we want the
3920 tmp_sym
->ts
.type
= BT_DERIVED
;
3921 if (s
== ISOCBINDING_LOC
)
3922 tmp_sym
->ts
.derived
=
3923 get_iso_c_binding_dt (ISOCBINDING_PTR
);
3925 tmp_sym
->ts
.derived
=
3926 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3928 if (tmp_sym
->ts
.derived
== NULL
)
3930 /* Create the necessary derived type so we can continue
3931 processing the file. */
3932 generate_isocbinding_symbol
3933 (mod_name
, s
== ISOCBINDING_FUNLOC
3934 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
3935 (const char *)(s
== ISOCBINDING_FUNLOC
3936 ? "_gfortran_iso_c_binding_c_funptr"
3937 : "_gfortran_iso_c_binding_c_ptr"));
3938 tmp_sym
->ts
.derived
=
3939 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
3940 ? ISOCBINDING_FUNPTR
3944 /* The function result is itself (no result clause). */
3945 tmp_sym
->result
= tmp_sym
;
3946 tmp_sym
->attr
.external
= 1;
3947 tmp_sym
->attr
.use_assoc
= 0;
3948 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
3949 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
3953 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
3954 tmp_sym
->attr
.contained
= 0;
3956 /* Try using this builder routine, with the new and old symbols
3957 both being the generic iso_c proc sym being created. This
3958 will create the formal args (and the new namespace for them).
3959 Don't build an arg list for c_loc because we're going to treat
3960 c_loc as an external procedure. */
3961 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
3962 /* The 1 says to add any optional args, if applicable. */
3963 build_formal_args (tmp_sym
, tmp_sym
, 1);
3965 /* Set this after setting up the symbol, to prevent error messages. */
3966 tmp_sym
->attr
.use_assoc
= 1;
3968 /* This symbol will not be referenced directly. It will be
3969 resolved to the implementation for the given f90 kind. */
3970 tmp_sym
->attr
.referenced
= 0;
3980 /* Creates a new symbol based off of an old iso_c symbol, with a new
3981 binding label. This function can be used to create a new,
3982 resolved, version of a procedure symbol for c_f_pointer or
3983 c_f_procpointer that is based on the generic symbols. A new
3984 parameter list is created for the new symbol using
3985 build_formal_args(). The add_optional_flag specifies whether the
3986 to add the optional SHAPE argument. The new symbol is
3990 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
3991 char *new_binding_label
, int add_optional_arg
)
3993 gfc_symtree
*new_symtree
= NULL
;
3995 /* See if we have a symbol by that name already available, looking
3996 through any parent namespaces. */
3997 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
3998 if (new_symtree
!= NULL
)
3999 /* Return the existing symbol. */
4000 return new_symtree
->n
.sym
;
4002 /* Create the symtree/symbol, with attempted host association. */
4003 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4004 if (new_symtree
== NULL
)
4005 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4006 "symtree for '%s'", new_name
);
4008 /* Now fill in the fields of the resolved symbol with the old sym. */
4009 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4010 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4011 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4012 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4013 /* Build the formal arg list. */
4014 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4016 gfc_commit_symbol (new_symtree
->n
.sym
);
4018 return new_symtree
->n
.sym
;