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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors
[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
39 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
40 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
41 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
45 const mstring procedures
[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
48 minit ("MODULE-PROC", PROC_MODULE
),
49 minit ("INTERNAL-PROC", PROC_INTERNAL
),
50 minit ("DUMMY-PROC", PROC_DUMMY
),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
57 const mstring intents
[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
60 minit ("IN", INTENT_IN
),
61 minit ("OUT", INTENT_OUT
),
62 minit ("INOUT", INTENT_INOUT
),
66 const mstring access_types
[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
69 minit ("PUBLIC", ACCESS_PUBLIC
),
70 minit ("PRIVATE", ACCESS_PRIVATE
),
74 const mstring ifsrc_types
[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN
),
77 minit ("DECL", IFSRC_DECL
),
78 minit ("BODY", IFSRC_IFBODY
),
79 minit ("USAGE", IFSRC_USAGE
)
82 const mstring save_status
[] =
84 minit ("UNKNOWN", SAVE_NONE
),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order
= 1;
95 gfc_namespace
*gfc_current_ns
;
97 gfc_gsymbol
*gfc_gsym_root
= NULL
;
99 static gfc_symbol
*changed_syms
= NULL
;
101 gfc_dt_list
*gfc_derived_types
;
104 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
106 /* The following static variable indicates whether a particular element has
107 been explicitly set or not. */
109 static int new_flag
[GFC_LETTERS
];
112 /* Handle a correctly parsed IMPLICIT NONE. */
115 gfc_set_implicit_none (void)
119 if (gfc_current_ns
->seen_implicit_none
)
121 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
125 gfc_current_ns
->seen_implicit_none
= 1;
127 for (i
= 0; i
< GFC_LETTERS
; i
++)
129 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
130 gfc_current_ns
->set_flag
[i
] = 1;
135 /* Reset the implicit range flags. */
138 gfc_clear_new_implicit (void)
142 for (i
= 0; i
< GFC_LETTERS
; i
++)
147 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
150 gfc_add_new_implicit_range (int c1
, int c2
)
157 for (i
= c1
; i
<= c2
; i
++)
161 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
173 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
174 the new implicit types back into the existing types will work. */
177 gfc_merge_new_implicit (gfc_typespec
*ts
)
181 if (gfc_current_ns
->seen_implicit_none
)
183 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
187 for (i
= 0; i
< GFC_LETTERS
; i
++)
192 if (gfc_current_ns
->set_flag
[i
])
194 gfc_error ("Letter %c already has an IMPLICIT type at %C",
198 gfc_current_ns
->default_type
[i
] = *ts
;
199 gfc_current_ns
->set_flag
[i
] = 1;
206 /* Given a symbol, return a pointer to the typespec for its default type. */
209 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
213 letter
= sym
->name
[0];
215 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
216 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
217 "gfortran developers, and should not be used for "
218 "implicitly typed variables");
220 if (letter
< 'a' || letter
> 'z')
221 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
226 return &ns
->default_type
[letter
- 'a'];
230 /* Given a pointer to a symbol, set its type according to the first
231 letter of its name. Fails if the letter in question has no default
235 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
239 if (sym
->ts
.type
!= BT_UNKNOWN
)
240 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
242 ts
= gfc_get_default_type (sym
, ns
);
244 if (ts
->type
== BT_UNKNOWN
)
246 if (error_flag
&& !sym
->attr
.untyped
)
248 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
249 sym
->name
, &sym
->declared_at
);
250 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
257 sym
->attr
.implicit_type
= 1;
259 if (sym
->attr
.is_bind_c
== 1)
261 /* BIND(C) variables should not be implicitly declared. */
262 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
263 "not be C interoperable", sym
->name
, &sym
->declared_at
);
264 sym
->ts
.f90_type
= sym
->ts
.type
;
267 if (sym
->attr
.dummy
!= 0)
269 if (sym
->ns
->proc_name
!= NULL
270 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
271 || sym
->ns
->proc_name
->attr
.function
!= 0)
272 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
274 /* Dummy args to a BIND(C) routine may not be interoperable if
275 they are implicitly typed. */
276 gfc_warning_now ("Implicity declared variable '%s' at %L may not "
277 "be C interoperable but it is a dummy argument to "
278 "the BIND(C) procedure '%s' at %L", sym
->name
,
279 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
280 &(sym
->ns
->proc_name
->declared_at
));
281 sym
->ts
.f90_type
= sym
->ts
.type
;
289 /* This function is called from parse.c(parse_progunit) to check the
290 type of the function is not implicitly typed in the host namespace
291 and to implicitly type the function result, if necessary. */
294 gfc_check_function_type (gfc_namespace
*ns
)
296 gfc_symbol
*proc
= ns
->proc_name
;
298 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
301 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
303 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
306 if (proc
->result
!= proc
)
308 proc
->ts
= proc
->result
->ts
;
309 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
310 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
311 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
312 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
317 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
318 proc
->result
->name
, &proc
->result
->declared_at
);
319 proc
->result
->attr
.untyped
= 1;
325 /******************** Symbol attribute stuff *********************/
327 /* This is a generic conflict-checker. We do this to avoid having a
328 single conflict in two places. */
330 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
331 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
332 #define conf_std(a, b, std) if (attr->a && attr->b)\
341 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
343 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
344 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
345 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
346 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
347 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
348 *private = "PRIVATE", *recursive
= "RECURSIVE",
349 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
350 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
351 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
352 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
353 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
354 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
355 *volatile_
= "VOLATILE", *protected = "PROTECTED",
356 *is_bind_c
= "BIND(C)";
357 static const char *threadprivate
= "THREADPRIVATE";
363 where
= &gfc_current_locus
;
365 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
369 standard
= GFC_STD_F2003
;
373 /* Check for attributes not allowed in a BLOCK DATA. */
374 if (gfc_current_state () == COMP_BLOCK_DATA
)
378 if (attr
->in_namelist
)
380 if (attr
->allocatable
)
386 if (attr
->access
== ACCESS_PRIVATE
)
388 if (attr
->access
== ACCESS_PUBLIC
)
390 if (attr
->intent
!= INTENT_UNKNOWN
)
396 ("%s attribute not allowed in BLOCK DATA program unit at %L",
402 if (attr
->save
== SAVE_EXPLICIT
)
405 conf (in_common
, save
);
408 switch (attr
->flavor
)
417 a1
= gfc_code2string (flavors
, attr
->flavor
);
429 conf (dummy
, intrinsic
);
430 conf (dummy
, threadprivate
);
431 conf (pointer
, target
);
432 conf (pointer
, intrinsic
);
433 conf (pointer
, elemental
);
434 conf (allocatable
, elemental
);
436 conf (target
, external
);
437 conf (target
, intrinsic
);
438 conf (external
, dimension
); /* See Fortran 95's R504. */
440 conf (external
, intrinsic
);
442 if (attr
->if_source
|| 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 a1
= gfc_code2string (flavors
, attr
->flavor
);
551 if (attr
->in_namelist
552 && attr
->flavor
!= FL_VARIABLE
553 && attr
->flavor
!= FL_PROCEDURE
554 && attr
->flavor
!= FL_UNKNOWN
)
560 switch (attr
->flavor
)
580 conf2 (threadprivate
);
590 if (attr
->subroutine
)
599 conf2 (threadprivate
);
604 case PROC_ST_FUNCTION
:
616 conf2 (threadprivate
);
636 conf2 (threadprivate
);
638 if (attr
->intent
!= INTENT_UNKNOWN
)
660 conf2 (threadprivate
);
661 /* TODO: hmm, double check this. */
673 gfc_error ("%s attribute conflicts with %s attribute at %L",
676 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
677 a1
, a2
, name
, where
);
684 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
685 "with %s attribute at %L", a1
, a2
,
690 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
691 "with %s attribute in '%s' at %L",
692 a1
, a2
, name
, where
);
701 /* Mark a symbol as referenced. */
704 gfc_set_sym_referenced (gfc_symbol
*sym
)
707 if (sym
->attr
.referenced
)
710 sym
->attr
.referenced
= 1;
712 /* Remember which order dummy variables are accessed in. */
714 sym
->dummy_order
= next_dummy_order
++;
718 /* Common subroutine called by attribute changing subroutines in order
719 to prevent them from changing a symbol that has been
720 use-associated. Returns zero if it is OK to change the symbol,
724 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
727 if (attr
->use_assoc
== 0)
731 where
= &gfc_current_locus
;
734 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
737 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
744 /* Generate an error because of a duplicate attribute. */
747 duplicate_attr (const char *attr
, locus
*where
)
751 where
= &gfc_current_locus
;
753 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
757 /* Called from decl.c (attr_decl1) to check attributes, when declared
761 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
764 if (check_used (attr
, NULL
, where
))
767 return check_conflict (attr
, NULL
, where
);
771 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
774 if (check_used (attr
, NULL
, where
))
777 if (attr
->allocatable
)
779 duplicate_attr ("ALLOCATABLE", where
);
783 attr
->allocatable
= 1;
784 return check_conflict (attr
, NULL
, where
);
789 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
792 if (check_used (attr
, name
, where
))
797 duplicate_attr ("DIMENSION", where
);
802 return check_conflict (attr
, name
, where
);
807 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
810 if (check_used (attr
, NULL
, where
))
815 duplicate_attr ("EXTERNAL", where
);
821 return check_conflict (attr
, NULL
, where
);
826 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
829 if (check_used (attr
, NULL
, where
))
834 duplicate_attr ("INTRINSIC", where
);
840 return check_conflict (attr
, NULL
, where
);
845 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
848 if (check_used (attr
, NULL
, where
))
853 duplicate_attr ("OPTIONAL", where
);
858 return check_conflict (attr
, NULL
, where
);
863 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
866 if (check_used (attr
, NULL
, where
))
870 return check_conflict (attr
, NULL
, where
);
875 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
878 if (check_used (attr
, NULL
, where
))
881 attr
->cray_pointer
= 1;
882 return check_conflict (attr
, NULL
, where
);
887 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
890 if (check_used (attr
, NULL
, where
))
893 if (attr
->cray_pointee
)
895 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
896 " statements", where
);
900 attr
->cray_pointee
= 1;
901 return check_conflict (attr
, NULL
, where
);
906 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
908 if (check_used (attr
, name
, where
))
913 if (gfc_notify_std (GFC_STD_LEGACY
,
914 "Duplicate PROTECTED attribute specified at %L",
921 return check_conflict (attr
, name
, where
);
926 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
929 if (check_used (attr
, name
, where
))
933 return check_conflict (attr
, name
, where
);
938 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
941 if (check_used (attr
, name
, where
))
947 ("SAVE attribute at %L cannot be specified in a PURE procedure",
952 if (attr
->save
== SAVE_EXPLICIT
)
954 if (gfc_notify_std (GFC_STD_LEGACY
,
955 "Duplicate SAVE attribute specified at %L",
961 attr
->save
= SAVE_EXPLICIT
;
962 return check_conflict (attr
, name
, where
);
967 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
970 if (check_used (attr
, name
, where
))
975 if (gfc_notify_std (GFC_STD_LEGACY
,
976 "Duplicate VALUE attribute specified at %L",
983 return check_conflict (attr
, name
, where
);
988 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
990 /* No check_used needed as 11.2.1 of the F2003 standard allows
991 that the local identifier made accessible by a use statement can be
992 given a VOLATILE attribute. */
994 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
995 if (gfc_notify_std (GFC_STD_LEGACY
,
996 "Duplicate VOLATILE attribute specified at %L", where
)
1000 attr
->volatile_
= 1;
1001 attr
->volatile_ns
= gfc_current_ns
;
1002 return check_conflict (attr
, name
, where
);
1007 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1010 if (check_used (attr
, name
, where
))
1013 if (attr
->threadprivate
)
1015 duplicate_attr ("THREADPRIVATE", where
);
1019 attr
->threadprivate
= 1;
1020 return check_conflict (attr
, name
, where
);
1025 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1028 if (check_used (attr
, NULL
, where
))
1033 duplicate_attr ("TARGET", where
);
1038 return check_conflict (attr
, NULL
, where
);
1043 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1046 if (check_used (attr
, name
, where
))
1049 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1051 return check_conflict (attr
, name
, where
);
1056 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1059 if (check_used (attr
, name
, where
))
1062 /* Duplicate attribute already checked for. */
1063 attr
->in_common
= 1;
1064 if (check_conflict (attr
, name
, where
) == FAILURE
)
1067 if (attr
->flavor
== FL_VARIABLE
)
1070 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1075 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1078 /* Duplicate attribute already checked for. */
1079 attr
->in_equivalence
= 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_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1094 if (check_used (attr
, name
, where
))
1098 return check_conflict (attr
, name
, where
);
1103 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1106 attr
->in_namelist
= 1;
1107 return check_conflict (attr
, name
, where
);
1112 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1115 if (check_used (attr
, name
, where
))
1119 return check_conflict (attr
, name
, where
);
1124 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1127 if (check_used (attr
, NULL
, where
))
1130 attr
->elemental
= 1;
1131 return check_conflict (attr
, NULL
, where
);
1136 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1139 if (check_used (attr
, NULL
, where
))
1143 return check_conflict (attr
, NULL
, where
);
1148 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1151 if (check_used (attr
, NULL
, where
))
1154 attr
->recursive
= 1;
1155 return check_conflict (attr
, NULL
, where
);
1160 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1163 if (check_used (attr
, name
, where
))
1168 duplicate_attr ("ENTRY", where
);
1173 return check_conflict (attr
, name
, where
);
1178 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1181 if (attr
->flavor
!= FL_PROCEDURE
1182 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1186 return check_conflict (attr
, name
, where
);
1191 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1194 if (attr
->flavor
!= FL_PROCEDURE
1195 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1198 attr
->subroutine
= 1;
1199 return check_conflict (attr
, name
, where
);
1204 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1207 if (attr
->flavor
!= FL_PROCEDURE
1208 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1212 return check_conflict (attr
, name
, where
);
1216 /* Flavors are special because some flavors are not what Fortran
1217 considers attributes and can be reaffirmed multiple times. */
1220 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1224 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1225 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1226 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1229 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1232 if (attr
->flavor
!= FL_UNKNOWN
)
1235 where
= &gfc_current_locus
;
1238 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1239 gfc_code2string (flavors
, attr
->flavor
), name
,
1240 gfc_code2string (flavors
, f
), where
);
1242 gfc_error ("%s attribute conflicts with %s attribute at %L",
1243 gfc_code2string (flavors
, attr
->flavor
),
1244 gfc_code2string (flavors
, f
), where
);
1251 return check_conflict (attr
, name
, where
);
1256 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1257 const char *name
, locus
*where
)
1260 if (check_used (attr
, name
, where
))
1263 if (attr
->flavor
!= FL_PROCEDURE
1264 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1268 where
= &gfc_current_locus
;
1270 if (attr
->proc
!= PROC_UNKNOWN
)
1272 gfc_error ("%s procedure at %L is already declared as %s procedure",
1273 gfc_code2string (procedures
, t
), where
,
1274 gfc_code2string (procedures
, attr
->proc
));
1281 /* Statement functions are always scalar and functions. */
1282 if (t
== PROC_ST_FUNCTION
1283 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1284 || attr
->dimension
))
1287 return check_conflict (attr
, name
, where
);
1292 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1295 if (check_used (attr
, NULL
, where
))
1298 if (attr
->intent
== INTENT_UNKNOWN
)
1300 attr
->intent
= intent
;
1301 return check_conflict (attr
, NULL
, where
);
1305 where
= &gfc_current_locus
;
1307 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1308 gfc_intent_string (attr
->intent
),
1309 gfc_intent_string (intent
), where
);
1315 /* No checks for use-association in public and private statements. */
1318 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1319 const char *name
, locus
*where
)
1322 if (attr
->access
== ACCESS_UNKNOWN
)
1324 attr
->access
= access
;
1325 return check_conflict (attr
, name
, where
);
1329 where
= &gfc_current_locus
;
1330 gfc_error ("ACCESS specification at %L was already specified", where
);
1336 /* Set the is_bind_c field for the given symbol_attribute. */
1339 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1340 int is_proc_lang_bind_spec
)
1343 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1344 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1345 "variables or common blocks", where
);
1346 else if (attr
->is_bind_c
)
1347 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1349 attr
->is_bind_c
= 1;
1352 where
= &gfc_current_locus
;
1354 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1358 return check_conflict (attr
, name
, where
);
1363 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1364 gfc_formal_arglist
* formal
, locus
*where
)
1367 if (check_used (&sym
->attr
, sym
->name
, where
))
1371 where
= &gfc_current_locus
;
1373 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1374 && sym
->attr
.if_source
!= IFSRC_DECL
)
1376 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1381 sym
->formal
= formal
;
1382 sym
->attr
.if_source
= source
;
1388 /* Add a type to a symbol. */
1391 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1396 where
= &gfc_current_locus
;
1398 if (sym
->ts
.type
!= BT_UNKNOWN
)
1400 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1401 if (!(sym
->ts
.type
== ts
->type
1402 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1403 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1406 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1409 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1410 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1414 flavor
= sym
->attr
.flavor
;
1416 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1417 || flavor
== FL_LABEL
1418 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1419 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1421 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1430 /* Clears all attributes. */
1433 gfc_clear_attr (symbol_attribute
*attr
)
1435 memset (attr
, 0, sizeof (symbol_attribute
));
1439 /* Check for missing attributes in the new symbol. Currently does
1440 nothing, but it's not clear that it is unnecessary yet. */
1443 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1444 locus
*where ATTRIBUTE_UNUSED
)
1451 /* Copy an attribute to a symbol attribute, bit by bit. Some
1452 attributes have a lot of side-effects but cannot be present given
1453 where we are called from, so we ignore some bits. */
1456 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1458 int is_proc_lang_bind_spec
;
1460 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1463 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1465 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1467 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1469 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1471 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1473 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1475 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1477 if (src
->threadprivate
1478 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1480 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1482 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1484 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1489 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1492 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1495 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1497 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1499 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1502 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1504 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1506 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1508 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1511 if (src
->flavor
!= FL_UNKNOWN
1512 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1515 if (src
->intent
!= INTENT_UNKNOWN
1516 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1519 if (src
->access
!= ACCESS_UNKNOWN
1520 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1523 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1526 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1528 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1531 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1533 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1537 if (src
->is_c_interop
)
1538 dest
->is_c_interop
= 1;
1542 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1544 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1554 /************** Component name management ************/
1556 /* Component names of a derived type form their own little namespaces
1557 that are separate from all other spaces. The space is composed of
1558 a singly linked list of gfc_component structures whose head is
1559 located in the parent symbol. */
1562 /* Add a component name to a symbol. The call fails if the name is
1563 already present. On success, the component pointer is modified to
1564 point to the additional component structure. */
1567 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1568 gfc_component
**component
)
1570 gfc_component
*p
, *tail
;
1574 for (p
= sym
->components
; p
; p
= p
->next
)
1576 if (strcmp (p
->name
, name
) == 0)
1578 gfc_error ("Component '%s' at %C already declared at %L",
1586 /* Allocate a new component. */
1587 p
= gfc_get_component ();
1590 sym
->components
= p
;
1594 p
->name
= gfc_get_string (name
);
1595 p
->loc
= gfc_current_locus
;
1602 /* Recursive function to switch derived types of all symbol in a
1606 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1614 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1615 sym
->ts
.derived
= to
;
1617 switch_types (st
->left
, from
, to
);
1618 switch_types (st
->right
, from
, to
);
1622 /* This subroutine is called when a derived type is used in order to
1623 make the final determination about which version to use. The
1624 standard requires that a type be defined before it is 'used', but
1625 such types can appear in IMPLICIT statements before the actual
1626 definition. 'Using' in this context means declaring a variable to
1627 be that type or using the type constructor.
1629 If a type is used and the components haven't been defined, then we
1630 have to have a derived type in a parent unit. We find the node in
1631 the other namespace and point the symtree node in this namespace to
1632 that node. Further reference to this name point to the correct
1633 node. If we can't find the node in a parent namespace, then we have
1636 This subroutine takes a pointer to a symbol node and returns a
1637 pointer to the translated node or NULL for an error. Usually there
1638 is no translation and we return the node we were passed. */
1641 gfc_use_derived (gfc_symbol
*sym
)
1648 if (sym
->components
!= NULL
)
1649 return sym
; /* Already defined. */
1651 if (sym
->ns
->parent
== NULL
)
1654 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1656 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1660 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1663 /* Get rid of symbol sym, translating all references to s. */
1664 for (i
= 0; i
< GFC_LETTERS
; i
++)
1666 t
= &sym
->ns
->default_type
[i
];
1667 if (t
->derived
== sym
)
1671 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1676 /* Unlink from list of modified symbols. */
1677 gfc_commit_symbol (sym
);
1679 switch_types (sym
->ns
->sym_root
, sym
, s
);
1681 /* TODO: Also have to replace sym -> s in other lists like
1682 namelists, common lists and interface lists. */
1683 gfc_free_symbol (sym
);
1688 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1694 /* Given a derived type node and a component name, try to locate the
1695 component structure. Returns the NULL pointer if the component is
1696 not found or the components are private. */
1699 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1706 sym
= gfc_use_derived (sym
);
1711 for (p
= sym
->components
; p
; p
= p
->next
)
1712 if (strcmp (p
->name
, name
) == 0)
1716 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1720 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1721 || p
->access
== ACCESS_PRIVATE
))
1723 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1733 /* Given a symbol, free all of the component structures and everything
1737 free_components (gfc_component
*p
)
1745 gfc_free_array_spec (p
->as
);
1746 gfc_free_expr (p
->initializer
);
1753 /* Set component attributes from a standard symbol attribute structure. */
1756 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1759 c
->dimension
= attr
->dimension
;
1760 c
->pointer
= attr
->pointer
;
1761 c
->allocatable
= attr
->allocatable
;
1762 c
->access
= attr
->access
;
1766 /* Get a standard symbol attribute structure given the component
1770 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1773 gfc_clear_attr (attr
);
1774 attr
->dimension
= c
->dimension
;
1775 attr
->pointer
= c
->pointer
;
1776 attr
->allocatable
= c
->allocatable
;
1777 attr
->access
= c
->access
;
1781 /******************** Statement label management ********************/
1783 /* Comparison function for statement labels, used for managing the
1787 compare_st_labels (void *a1
, void *b1
)
1789 int a
= ((gfc_st_label
*) a1
)->value
;
1790 int b
= ((gfc_st_label
*) b1
)->value
;
1796 /* Free a single gfc_st_label structure, making sure the tree is not
1797 messed up. This function is called only when some parse error
1801 gfc_free_st_label (gfc_st_label
*label
)
1807 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1809 if (label
->format
!= NULL
)
1810 gfc_free_expr (label
->format
);
1816 /* Free a whole tree of gfc_st_label structures. */
1819 free_st_labels (gfc_st_label
*label
)
1825 free_st_labels (label
->left
);
1826 free_st_labels (label
->right
);
1828 if (label
->format
!= NULL
)
1829 gfc_free_expr (label
->format
);
1834 /* Given a label number, search for and return a pointer to the label
1835 structure, creating it if it does not exist. */
1838 gfc_get_st_label (int labelno
)
1842 /* First see if the label is already in this namespace. */
1843 lp
= gfc_current_ns
->st_labels
;
1846 if (lp
->value
== labelno
)
1849 if (lp
->value
< labelno
)
1855 lp
= gfc_getmem (sizeof (gfc_st_label
));
1857 lp
->value
= labelno
;
1858 lp
->defined
= ST_LABEL_UNKNOWN
;
1859 lp
->referenced
= ST_LABEL_UNKNOWN
;
1861 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1867 /* Called when a statement with a statement label is about to be
1868 accepted. We add the label to the list of the current namespace,
1869 making sure it hasn't been defined previously and referenced
1873 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1877 labelno
= lp
->value
;
1879 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1880 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1881 &lp
->where
, label_locus
);
1884 lp
->where
= *label_locus
;
1888 case ST_LABEL_FORMAT
:
1889 if (lp
->referenced
== ST_LABEL_TARGET
)
1890 gfc_error ("Label %d at %C already referenced as branch target",
1893 lp
->defined
= ST_LABEL_FORMAT
;
1897 case ST_LABEL_TARGET
:
1898 if (lp
->referenced
== ST_LABEL_FORMAT
)
1899 gfc_error ("Label %d at %C already referenced as a format label",
1902 lp
->defined
= ST_LABEL_TARGET
;
1907 lp
->defined
= ST_LABEL_BAD_TARGET
;
1908 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1914 /* Reference a label. Given a label and its type, see if that
1915 reference is consistent with what is known about that label,
1916 updating the unknown state. Returns FAILURE if something goes
1920 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1922 gfc_sl_type label_type
;
1929 labelno
= lp
->value
;
1931 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1932 label_type
= lp
->defined
;
1935 label_type
= lp
->referenced
;
1936 lp
->where
= gfc_current_locus
;
1939 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1941 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1946 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1947 && type
== ST_LABEL_FORMAT
)
1949 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1954 lp
->referenced
= type
;
1962 /*******A helper function for creating new expressions*************/
1966 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
1969 lval
= gfc_get_expr ();
1970 lval
->expr_type
= EXPR_VARIABLE
;
1971 lval
->where
= sym
->declared_at
;
1973 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1975 /* It will always be a full array. */
1976 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
1979 lval
->ref
= gfc_get_ref ();
1980 lval
->ref
->type
= REF_ARRAY
;
1981 lval
->ref
->u
.ar
.type
= AR_FULL
;
1982 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
1983 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
1984 lval
->ref
->u
.ar
.as
= sym
->as
;
1991 /************** Symbol table management subroutines ****************/
1993 /* Basic details: Fortran 95 requires a potentially unlimited number
1994 of distinct namespaces when compiling a program unit. This case
1995 occurs during a compilation of internal subprograms because all of
1996 the internal subprograms must be read before we can start
1997 generating code for the host.
1999 Given the tricky nature of the Fortran grammar, we must be able to
2000 undo changes made to a symbol table if the current interpretation
2001 of a statement is found to be incorrect. Whenever a symbol is
2002 looked up, we make a copy of it and link to it. All of these
2003 symbols are kept in a singly linked list so that we can commit or
2004 undo the changes at a later time.
2006 A symtree may point to a symbol node outside of its namespace. In
2007 this case, that symbol has been used as a host associated variable
2008 at some previous time. */
2010 /* Allocate a new namespace structure. Copies the implicit types from
2011 PARENT if PARENT_TYPES is set. */
2014 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2018 gfc_intrinsic_op in
;
2021 ns
= gfc_getmem (sizeof (gfc_namespace
));
2022 ns
->sym_root
= NULL
;
2023 ns
->uop_root
= NULL
;
2024 ns
->default_access
= ACCESS_UNKNOWN
;
2025 ns
->parent
= parent
;
2027 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2028 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2030 /* Initialize default implicit types. */
2031 for (i
= 'a'; i
<= 'z'; i
++)
2033 ns
->set_flag
[i
- 'a'] = 0;
2034 ts
= &ns
->default_type
[i
- 'a'];
2036 if (parent_types
&& ns
->parent
!= NULL
)
2038 /* Copy parent settings. */
2039 *ts
= ns
->parent
->default_type
[i
- 'a'];
2043 if (gfc_option
.flag_implicit_none
!= 0)
2049 if ('i' <= i
&& i
<= 'n')
2051 ts
->type
= BT_INTEGER
;
2052 ts
->kind
= gfc_default_integer_kind
;
2057 ts
->kind
= gfc_default_real_kind
;
2067 /* Comparison function for symtree nodes. */
2070 compare_symtree (void *_st1
, void *_st2
)
2072 gfc_symtree
*st1
, *st2
;
2074 st1
= (gfc_symtree
*) _st1
;
2075 st2
= (gfc_symtree
*) _st2
;
2077 return strcmp (st1
->name
, st2
->name
);
2081 /* Allocate a new symtree node and associate it with the new symbol. */
2084 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2088 st
= gfc_getmem (sizeof (gfc_symtree
));
2089 st
->name
= gfc_get_string (name
);
2091 gfc_insert_bbt (root
, st
, compare_symtree
);
2096 /* Delete a symbol from the tree. Does not free the symbol itself! */
2099 delete_symtree (gfc_symtree
**root
, const char *name
)
2101 gfc_symtree st
, *st0
;
2103 st0
= gfc_find_symtree (*root
, name
);
2105 st
.name
= gfc_get_string (name
);
2106 gfc_delete_bbt (root
, &st
, compare_symtree
);
2112 /* Given a root symtree node and a name, try to find the symbol within
2113 the namespace. Returns NULL if the symbol is not found. */
2116 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2122 c
= strcmp (name
, st
->name
);
2126 st
= (c
< 0) ? st
->left
: st
->right
;
2133 /* Given a name find a user operator node, creating it if it doesn't
2134 exist. These are much simpler than symbols because they can't be
2135 ambiguous with one another. */
2138 gfc_get_uop (const char *name
)
2143 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2147 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2149 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2150 uop
->name
= gfc_get_string (name
);
2151 uop
->access
= ACCESS_UNKNOWN
;
2152 uop
->ns
= gfc_current_ns
;
2158 /* Given a name find the user operator node. Returns NULL if it does
2162 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2167 ns
= gfc_current_ns
;
2169 st
= gfc_find_symtree (ns
->uop_root
, name
);
2170 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2174 /* Remove a gfc_symbol structure and everything it points to. */
2177 gfc_free_symbol (gfc_symbol
*sym
)
2183 gfc_free_array_spec (sym
->as
);
2185 free_components (sym
->components
);
2187 gfc_free_expr (sym
->value
);
2189 gfc_free_namelist (sym
->namelist
);
2191 gfc_free_namespace (sym
->formal_ns
);
2193 if (!sym
->attr
.generic_copy
)
2194 gfc_free_interface (sym
->generic
);
2196 gfc_free_formal_arglist (sym
->formal
);
2202 /* Allocate and initialize a new symbol node. */
2205 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2209 p
= gfc_getmem (sizeof (gfc_symbol
));
2211 gfc_clear_ts (&p
->ts
);
2212 gfc_clear_attr (&p
->attr
);
2215 p
->declared_at
= gfc_current_locus
;
2217 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2218 gfc_internal_error ("new_symbol(): Symbol name too long");
2220 p
->name
= gfc_get_string (name
);
2222 /* Make sure flags for symbol being C bound are clear initially. */
2223 p
->attr
.is_bind_c
= 0;
2224 p
->attr
.is_iso_c
= 0;
2225 /* Make sure the binding label field has a Nul char to start. */
2226 p
->binding_label
[0] = '\0';
2228 /* Clear the ptrs we may need. */
2229 p
->common_block
= NULL
;
2235 /* Generate an error if a symbol is ambiguous. */
2238 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2241 if (st
->n
.sym
->module
)
2242 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2243 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2245 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2246 "from current program unit", name
, st
->n
.sym
->name
);
2250 /* Search for a symtree starting in the current namespace, resorting to
2251 any parent namespaces if requested by a nonzero parent_flag.
2252 Returns nonzero if the name is ambiguous. */
2255 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2256 gfc_symtree
**result
)
2261 ns
= gfc_current_ns
;
2265 st
= gfc_find_symtree (ns
->sym_root
, name
);
2269 /* Ambiguous generic interfaces are permitted, as long
2270 as the specific interfaces are different. */
2271 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2273 ambiguous_symbol (name
, st
);
2292 /* Same, but returns the symbol instead. */
2295 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2296 gfc_symbol
**result
)
2301 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2306 *result
= st
->n
.sym
;
2312 /* Save symbol with the information necessary to back it out. */
2315 save_symbol_data (gfc_symbol
*sym
)
2318 if (sym
->new || sym
->old_symbol
!= NULL
)
2321 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2322 *(sym
->old_symbol
) = *sym
;
2324 sym
->tlink
= changed_syms
;
2329 /* Given a name, find a symbol, or create it if it does not exist yet
2330 in the current namespace. If the symbol is found we make sure that
2333 The integer return code indicates
2335 1 The symbol name was ambiguous
2336 2 The name meant to be established was already host associated.
2338 So if the return value is nonzero, then an error was issued. */
2341 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2346 /* This doesn't usually happen during resolution. */
2348 ns
= gfc_current_ns
;
2350 /* Try to find the symbol in ns. */
2351 st
= gfc_find_symtree (ns
->sym_root
, name
);
2355 /* If not there, create a new symbol. */
2356 p
= gfc_new_symbol (name
, ns
);
2358 /* Add to the list of tentative symbols. */
2359 p
->old_symbol
= NULL
;
2360 p
->tlink
= changed_syms
;
2365 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2372 /* Make sure the existing symbol is OK. Ambiguous
2373 generic interfaces are permitted, as long as the
2374 specific interfaces are different. */
2375 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2377 ambiguous_symbol (name
, st
);
2383 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2385 /* Symbol is from another namespace. */
2386 gfc_error ("Symbol '%s' at %C has already been host associated",
2393 /* Copy in case this symbol is changed. */
2394 save_symbol_data (p
);
2403 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2408 i
= gfc_get_sym_tree (name
, ns
, &st
);
2413 *result
= st
->n
.sym
;
2420 /* Subroutine that searches for a symbol, creating it if it doesn't
2421 exist, but tries to host-associate the symbol if possible. */
2424 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2429 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2432 save_symbol_data (st
->n
.sym
);
2437 if (gfc_current_ns
->parent
!= NULL
)
2439 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2450 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2455 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2460 i
= gfc_get_ha_sym_tree (name
, &st
);
2463 *result
= st
->n
.sym
;
2470 /* Return true if both symbols could refer to the same data object. Does
2471 not take account of aliasing due to equivalence statements. */
2474 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2476 /* Aliasing isn't possible if the symbols have different base types. */
2477 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2480 /* Pointers can point to other pointers, target objects and allocatable
2481 objects. Two allocatable objects cannot share the same storage. */
2482 if (lsym
->attr
.pointer
2483 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2485 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2487 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2494 /* Undoes all the changes made to symbols in the current statement.
2495 This subroutine is made simpler due to the fact that attributes are
2496 never removed once added. */
2499 gfc_undo_symbols (void)
2501 gfc_symbol
*p
, *q
, *old
;
2503 for (p
= changed_syms
; p
; p
= q
)
2509 /* Symbol was new. */
2510 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2514 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2516 gfc_free_symbol (p
);
2520 /* Restore previous state of symbol. Just copy simple stuff. */
2522 old
= p
->old_symbol
;
2524 p
->ts
.type
= old
->ts
.type
;
2525 p
->ts
.kind
= old
->ts
.kind
;
2527 p
->attr
= old
->attr
;
2529 if (p
->value
!= old
->value
)
2531 gfc_free_expr (old
->value
);
2535 if (p
->as
!= old
->as
)
2538 gfc_free_array_spec (p
->as
);
2542 p
->generic
= old
->generic
;
2543 p
->component_access
= old
->component_access
;
2545 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2547 gfc_free_namelist (p
->namelist
);
2552 if (p
->namelist_tail
!= old
->namelist_tail
)
2554 gfc_free_namelist (old
->namelist_tail
);
2555 old
->namelist_tail
->next
= NULL
;
2559 p
->namelist_tail
= old
->namelist_tail
;
2561 if (p
->formal
!= old
->formal
)
2563 gfc_free_formal_arglist (p
->formal
);
2564 p
->formal
= old
->formal
;
2567 gfc_free (p
->old_symbol
);
2568 p
->old_symbol
= NULL
;
2572 changed_syms
= NULL
;
2576 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2577 components of old_symbol that might need deallocation are the "allocatables"
2578 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2579 namelist_tail. In case these differ between old_symbol and sym, it's just
2580 because sym->namelist has gotten a few more items. */
2583 free_old_symbol (gfc_symbol
*sym
)
2586 if (sym
->old_symbol
== NULL
)
2589 if (sym
->old_symbol
->as
!= sym
->as
)
2590 gfc_free_array_spec (sym
->old_symbol
->as
);
2592 if (sym
->old_symbol
->value
!= sym
->value
)
2593 gfc_free_expr (sym
->old_symbol
->value
);
2595 if (sym
->old_symbol
->formal
!= sym
->formal
)
2596 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2598 gfc_free (sym
->old_symbol
);
2599 sym
->old_symbol
= NULL
;
2603 /* Makes the changes made in the current statement permanent-- gets
2604 rid of undo information. */
2607 gfc_commit_symbols (void)
2611 for (p
= changed_syms
; p
; p
= q
)
2617 free_old_symbol (p
);
2619 changed_syms
= NULL
;
2623 /* Makes the changes made in one symbol permanent -- gets rid of undo
2627 gfc_commit_symbol (gfc_symbol
*sym
)
2631 if (changed_syms
== sym
)
2632 changed_syms
= sym
->tlink
;
2635 for (p
= changed_syms
; p
; p
= p
->tlink
)
2636 if (p
->tlink
== sym
)
2638 p
->tlink
= sym
->tlink
;
2647 free_old_symbol (sym
);
2651 /* Recursive function that deletes an entire tree and all the common
2652 head structures it points to. */
2655 free_common_tree (gfc_symtree
* common_tree
)
2657 if (common_tree
== NULL
)
2660 free_common_tree (common_tree
->left
);
2661 free_common_tree (common_tree
->right
);
2663 gfc_free (common_tree
);
2667 /* Recursive function that deletes an entire tree and all the user
2668 operator nodes that it contains. */
2671 free_uop_tree (gfc_symtree
*uop_tree
)
2674 if (uop_tree
== NULL
)
2677 free_uop_tree (uop_tree
->left
);
2678 free_uop_tree (uop_tree
->right
);
2680 gfc_free_interface (uop_tree
->n
.uop
->operator);
2682 gfc_free (uop_tree
->n
.uop
);
2683 gfc_free (uop_tree
);
2687 /* Recursive function that deletes an entire tree and all the symbols
2688 that it contains. */
2691 free_sym_tree (gfc_symtree
*sym_tree
)
2696 if (sym_tree
== NULL
)
2699 free_sym_tree (sym_tree
->left
);
2700 free_sym_tree (sym_tree
->right
);
2702 sym
= sym_tree
->n
.sym
;
2706 gfc_internal_error ("free_sym_tree(): Negative refs");
2708 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2710 /* As formal_ns contains a reference to sym, delete formal_ns just
2711 before the deletion of sym. */
2712 ns
= sym
->formal_ns
;
2713 sym
->formal_ns
= NULL
;
2714 gfc_free_namespace (ns
);
2716 else if (sym
->refs
== 0)
2718 /* Go ahead and delete the symbol. */
2719 gfc_free_symbol (sym
);
2722 gfc_free (sym_tree
);
2726 /* Free the derived type list. */
2729 gfc_free_dt_list (void)
2731 gfc_dt_list
*dt
, *n
;
2733 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2739 gfc_derived_types
= NULL
;
2743 /* Free the gfc_equiv_info's. */
2746 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2750 gfc_free_equiv_infos (s
->next
);
2755 /* Free the gfc_equiv_lists. */
2758 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2762 gfc_free_equiv_lists (l
->next
);
2763 gfc_free_equiv_infos (l
->equiv
);
2768 /* Free a namespace structure and everything below it. Interface
2769 lists associated with intrinsic operators are not freed. These are
2770 taken care of when a specific name is freed. */
2773 gfc_free_namespace (gfc_namespace
*ns
)
2775 gfc_charlen
*cl
, *cl2
;
2776 gfc_namespace
*p
, *q
;
2785 gcc_assert (ns
->refs
== 0);
2787 gfc_free_statements (ns
->code
);
2789 free_sym_tree (ns
->sym_root
);
2790 free_uop_tree (ns
->uop_root
);
2791 free_common_tree (ns
->common_root
);
2793 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2796 gfc_free_expr (cl
->length
);
2800 free_st_labels (ns
->st_labels
);
2802 gfc_free_equiv (ns
->equiv
);
2803 gfc_free_equiv_lists (ns
->equiv_lists
);
2805 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2806 gfc_free_interface (ns
->operator[i
]);
2808 gfc_free_data (ns
->data
);
2812 /* Recursively free any contained namespaces. */
2817 gfc_free_namespace (q
);
2823 gfc_symbol_init_2 (void)
2826 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2831 gfc_symbol_done_2 (void)
2834 gfc_free_namespace (gfc_current_ns
);
2835 gfc_current_ns
= NULL
;
2836 gfc_free_dt_list ();
2840 /* Clear mark bits from symbol nodes associated with a symtree node. */
2843 clear_sym_mark (gfc_symtree
*st
)
2846 st
->n
.sym
->mark
= 0;
2850 /* Recursively traverse the symtree nodes. */
2853 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2859 gfc_traverse_symtree (st
->left
, func
);
2860 gfc_traverse_symtree (st
->right
, func
);
2865 /* Recursive namespace traversal function. */
2868 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2874 if (st
->n
.sym
->mark
== 0)
2875 (*func
) (st
->n
.sym
);
2876 st
->n
.sym
->mark
= 1;
2878 traverse_ns (st
->left
, func
);
2879 traverse_ns (st
->right
, func
);
2883 /* Call a given function for all symbols in the namespace. We take
2884 care that each gfc_symbol node is called exactly once. */
2887 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2890 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2892 traverse_ns (ns
->sym_root
, func
);
2896 /* Return TRUE if the symbol is an automatic variable. */
2899 gfc_is_var_automatic (gfc_symbol
*sym
)
2901 /* Pointer and allocatable variables are never automatic. */
2902 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2904 /* Check for arrays with non-constant size. */
2905 if (sym
->attr
.dimension
&& sym
->as
2906 && !gfc_is_compile_time_shape (sym
->as
))
2908 /* Check for non-constant length character variables. */
2909 if (sym
->ts
.type
== BT_CHARACTER
2911 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2916 /* Given a symbol, mark it as SAVEd if it is allowed. */
2919 save_symbol (gfc_symbol
*sym
)
2922 if (sym
->attr
.use_assoc
)
2925 if (sym
->attr
.in_common
2927 || sym
->attr
.flavor
!= FL_VARIABLE
)
2929 /* Automatic objects are not saved. */
2930 if (gfc_is_var_automatic (sym
))
2932 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2936 /* Mark those symbols which can be SAVEd as such. */
2939 gfc_save_all (gfc_namespace
*ns
)
2942 gfc_traverse_ns (ns
, save_symbol
);
2947 /* Make sure that no changes to symbols are pending. */
2950 gfc_symbol_state(void) {
2952 if (changed_syms
!= NULL
)
2953 gfc_internal_error("Symbol changes still pending!");
2958 /************** Global symbol handling ************/
2961 /* Search a tree for the global symbol. */
2964 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2973 c
= strcmp (name
, symbol
->name
);
2977 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2984 /* Compare two global symbols. Used for managing the BB tree. */
2987 gsym_compare (void *_s1
, void *_s2
)
2989 gfc_gsymbol
*s1
, *s2
;
2991 s1
= (gfc_gsymbol
*) _s1
;
2992 s2
= (gfc_gsymbol
*) _s2
;
2993 return strcmp (s1
->name
, s2
->name
);
2997 /* Get a global symbol, creating it if it doesn't exist. */
3000 gfc_get_gsymbol (const char *name
)
3004 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3008 s
= gfc_getmem (sizeof (gfc_gsymbol
));
3009 s
->type
= GSYM_UNKNOWN
;
3010 s
->name
= gfc_get_string (name
);
3012 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3019 get_iso_c_binding_dt (int sym_id
)
3021 gfc_dt_list
*dt_list
;
3023 dt_list
= gfc_derived_types
;
3025 /* Loop through the derived types in the name list, searching for
3026 the desired symbol from iso_c_binding. Search the parent namespaces
3027 if necessary and requested to (parent_flag). */
3028 while (dt_list
!= NULL
)
3030 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3031 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3032 return dt_list
->derived
;
3034 dt_list
= dt_list
->next
;
3041 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3042 with C. This is necessary for any derived type that is BIND(C) and for
3043 derived types that are parameters to functions that are BIND(C). All
3044 fields of the derived type are required to be interoperable, and are tested
3045 for such. If an error occurs, the errors are reported here, allowing for
3046 multiple errors to be handled for a single derived type. */
3049 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3051 gfc_component
*curr_comp
= NULL
;
3052 try is_c_interop
= FAILURE
;
3053 try retval
= SUCCESS
;
3055 if (derived_sym
== NULL
)
3056 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3057 "unexpectedly NULL");
3059 /* If we've already looked at this derived symbol, do not look at it again
3060 so we don't repeat warnings/errors. */
3061 if (derived_sym
->ts
.is_c_interop
)
3064 /* The derived type must have the BIND attribute to be interoperable
3065 J3/04-007, Section 15.2.3. */
3066 if (derived_sym
->attr
.is_bind_c
!= 1)
3068 derived_sym
->ts
.is_c_interop
= 0;
3069 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3070 "attribute to be C interoperable", derived_sym
->name
,
3071 &(derived_sym
->declared_at
));
3075 curr_comp
= derived_sym
->components
;
3077 /* TODO: is this really an error? */
3078 if (curr_comp
== NULL
)
3080 gfc_error ("Derived type '%s' at %L is empty",
3081 derived_sym
->name
, &(derived_sym
->declared_at
));
3085 /* Initialize the derived type as being C interoperable.
3086 If we find an error in the components, this will be set false. */
3087 derived_sym
->ts
.is_c_interop
= 1;
3089 /* Loop through the list of components to verify that the kind of
3090 each is a C interoperable type. */
3093 /* The components cannot be pointers (fortran sense).
3094 J3/04-007, Section 15.2.3, C1505. */
3095 if (curr_comp
->pointer
!= 0)
3097 gfc_error ("Component '%s' at %L cannot have the "
3098 "POINTER attribute because it is a member "
3099 "of the BIND(C) derived type '%s' at %L",
3100 curr_comp
->name
, &(curr_comp
->loc
),
3101 derived_sym
->name
, &(derived_sym
->declared_at
));
3105 /* The components cannot be allocatable.
3106 J3/04-007, Section 15.2.3, C1505. */
3107 if (curr_comp
->allocatable
!= 0)
3109 gfc_error ("Component '%s' at %L cannot have the "
3110 "ALLOCATABLE attribute because it is a member "
3111 "of the BIND(C) derived type '%s' at %L",
3112 curr_comp
->name
, &(curr_comp
->loc
),
3113 derived_sym
->name
, &(derived_sym
->declared_at
));
3117 /* BIND(C) derived types must have interoperable components. */
3118 if (curr_comp
->ts
.type
== BT_DERIVED
3119 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3120 && curr_comp
->ts
.derived
!= derived_sym
)
3122 /* This should be allowed; the draft says a derived-type can not
3123 have type parameters if it is has the BIND attribute. Type
3124 parameters seem to be for making parameterized derived types.
3125 There's no need to verify the type if it is c_ptr/c_funptr. */
3126 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3130 /* Grab the typespec for the given component and test the kind. */
3131 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3134 if (is_c_interop
!= SUCCESS
)
3136 /* Report warning and continue since not fatal. The
3137 draft does specify a constraint that requires all fields
3138 to interoperate, but if the user says real(4), etc., it
3139 may interoperate with *something* in C, but the compiler
3140 most likely won't know exactly what. Further, it may not
3141 interoperate with the same data type(s) in C if the user
3142 recompiles with different flags (e.g., -m32 and -m64 on
3143 x86_64 and using integer(4) to claim interop with a
3145 if (derived_sym
->attr
.is_bind_c
== 1)
3146 /* If the derived type is bind(c), all fields must be
3148 gfc_warning ("Component '%s' in derived type '%s' at %L "
3149 "may not be C interoperable, even though "
3150 "derived type '%s' is BIND(C)",
3151 curr_comp
->name
, derived_sym
->name
,
3152 &(curr_comp
->loc
), derived_sym
->name
);
3154 /* If derived type is param to bind(c) routine, or to one
3155 of the iso_c_binding procs, it must be interoperable, so
3156 all fields must interop too. */
3157 gfc_warning ("Component '%s' in derived type '%s' at %L "
3158 "may not be C interoperable",
3159 curr_comp
->name
, derived_sym
->name
,
3164 curr_comp
= curr_comp
->next
;
3165 } while (curr_comp
!= NULL
);
3168 /* Make sure we don't have conflicts with the attributes. */
3169 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3171 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3172 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3173 &(derived_sym
->declared_at
));
3177 if (derived_sym
->attr
.sequence
!= 0)
3179 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3180 "attribute because it is BIND(C)", derived_sym
->name
,
3181 &(derived_sym
->declared_at
));
3185 /* Mark the derived type as not being C interoperable if we found an
3186 error. If there were only warnings, proceed with the assumption
3187 it's interoperable. */
3188 if (retval
== FAILURE
)
3189 derived_sym
->ts
.is_c_interop
= 0;
3195 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3198 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3199 const char *module_name
)
3201 gfc_symtree
*tmp_symtree
;
3202 gfc_symbol
*tmp_sym
;
3204 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3206 if (tmp_symtree
!= NULL
)
3207 tmp_sym
= tmp_symtree
->n
.sym
;
3211 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3212 "create symbol for %s", ptr_name
);
3215 /* Set up the symbol's important fields. Save attr required so we can
3216 initialize the ptr to NULL. */
3217 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3218 tmp_sym
->ts
.is_c_interop
= 1;
3219 tmp_sym
->attr
.is_c_interop
= 1;
3220 tmp_sym
->ts
.is_iso_c
= 1;
3221 tmp_sym
->ts
.type
= BT_DERIVED
;
3223 /* The c_ptr and c_funptr derived types will provide the
3224 definition for c_null_ptr and c_null_funptr, respectively. */
3225 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3226 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3228 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3229 if (tmp_sym
->ts
.derived
== NULL
)
3231 /* This can occur if the user forgot to declare c_ptr or
3232 c_funptr and they're trying to use one of the procedures
3233 that has arg(s) of the missing type. In this case, a
3234 regular version of the thing should have been put in the
3236 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3237 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3238 (char *) (ptr_id
== ISOCBINDING_NULL_PTR
3239 ? "_gfortran_iso_c_binding_c_ptr"
3240 : "_gfortran_iso_c_binding_c_funptr"));
3242 tmp_sym
->ts
.derived
=
3243 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3244 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3247 /* Module name is some mangled version of iso_c_binding. */
3248 tmp_sym
->module
= gfc_get_string (module_name
);
3250 /* Say it's from the iso_c_binding module. */
3251 tmp_sym
->attr
.is_iso_c
= 1;
3253 tmp_sym
->attr
.use_assoc
= 1;
3254 tmp_sym
->attr
.is_bind_c
= 1;
3255 /* Set the binding_label. */
3256 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3258 /* Set the c_address field of c_null_ptr and c_null_funptr to
3259 the value of NULL. */
3260 tmp_sym
->value
= gfc_get_expr ();
3261 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3262 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3263 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3264 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3265 /* This line will initialize the c_null_ptr/c_null_funptr
3266 c_address field to NULL. */
3267 tmp_sym
->value
->value
.constructor
->expr
= gfc_int_expr (0);
3268 /* Must declare c_null_ptr and c_null_funptr as having the
3269 PARAMETER attribute so they can be used in init expressions. */
3270 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3276 /* Add a formal argument, gfc_formal_arglist, to the
3277 end of the given list of arguments. Set the reference to the
3278 provided symbol, param_sym, in the argument. */
3281 add_formal_arg (gfc_formal_arglist
**head
,
3282 gfc_formal_arglist
**tail
,
3283 gfc_formal_arglist
*formal_arg
,
3284 gfc_symbol
*param_sym
)
3286 /* Put in list, either as first arg or at the tail (curr arg). */
3288 *head
= *tail
= formal_arg
;
3291 (*tail
)->next
= formal_arg
;
3292 (*tail
) = formal_arg
;
3295 (*tail
)->sym
= param_sym
;
3296 (*tail
)->next
= NULL
;
3302 /* Generates a symbol representing the CPTR argument to an
3303 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3304 CPTR and add it to the provided argument list. */
3307 gen_cptr_param (gfc_formal_arglist
**head
,
3308 gfc_formal_arglist
**tail
,
3309 const char *module_name
,
3310 gfc_namespace
*ns
, const char *c_ptr_name
,
3313 gfc_symbol
*param_sym
= NULL
;
3314 gfc_symbol
*c_ptr_sym
= NULL
;
3315 gfc_symtree
*param_symtree
= NULL
;
3316 gfc_formal_arglist
*formal_arg
= NULL
;
3317 const char *c_ptr_in
;
3318 const char *c_ptr_type
= NULL
;
3320 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3321 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3323 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3325 if(c_ptr_name
== NULL
)
3326 c_ptr_in
= "gfc_cptr__";
3328 c_ptr_in
= c_ptr_name
;
3329 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3330 if (param_symtree
!= NULL
)
3331 param_sym
= param_symtree
->n
.sym
;
3333 gfc_internal_error ("gen_cptr_param(): Unable to "
3334 "create symbol for %s", c_ptr_in
);
3336 /* Set up the appropriate fields for the new c_ptr param sym. */
3338 param_sym
->attr
.flavor
= FL_DERIVED
;
3339 param_sym
->ts
.type
= BT_DERIVED
;
3340 param_sym
->attr
.intent
= INTENT_IN
;
3341 param_sym
->attr
.dummy
= 1;
3343 /* This will pass the ptr to the iso_c routines as a (void *). */
3344 param_sym
->attr
.value
= 1;
3345 param_sym
->attr
.use_assoc
= 1;
3347 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3349 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3350 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3352 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3353 if (c_ptr_sym
== NULL
)
3355 /* This can happen if the user did not define c_ptr but they are
3356 trying to use one of the iso_c_binding functions that need it. */
3357 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3358 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3359 (char *)c_ptr_type
);
3361 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3362 (char *)c_ptr_type
);
3364 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3367 param_sym
->ts
.derived
= c_ptr_sym
;
3368 param_sym
->module
= gfc_get_string (module_name
);
3370 /* Make new formal arg. */
3371 formal_arg
= gfc_get_formal_arglist ();
3372 /* Add arg to list of formal args (the CPTR arg). */
3373 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3377 /* Generates a symbol representing the FPTR argument to an
3378 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3379 FPTR and add it to the provided argument list. */
3382 gen_fptr_param (gfc_formal_arglist
**head
,
3383 gfc_formal_arglist
**tail
,
3384 const char *module_name
,
3385 gfc_namespace
*ns
, const char *f_ptr_name
)
3387 gfc_symbol
*param_sym
= NULL
;
3388 gfc_symtree
*param_symtree
= NULL
;
3389 gfc_formal_arglist
*formal_arg
= NULL
;
3390 const char *f_ptr_out
= "gfc_fptr__";
3392 if (f_ptr_name
!= NULL
)
3393 f_ptr_out
= f_ptr_name
;
3395 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3396 if (param_symtree
!= NULL
)
3397 param_sym
= param_symtree
->n
.sym
;
3399 gfc_internal_error ("generateFPtrParam(): Unable to "
3400 "create symbol for %s", f_ptr_out
);
3402 /* Set up the necessary fields for the fptr output param sym. */
3404 param_sym
->attr
.pointer
= 1;
3405 param_sym
->attr
.dummy
= 1;
3406 param_sym
->attr
.use_assoc
= 1;
3408 /* ISO C Binding type to allow any pointer type as actual param. */
3409 param_sym
->ts
.type
= BT_VOID
;
3410 param_sym
->module
= gfc_get_string (module_name
);
3413 formal_arg
= gfc_get_formal_arglist ();
3414 /* Add arg to list of formal args. */
3415 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3419 /* Generates a symbol representing the optional SHAPE argument for the
3420 iso_c_binding c_f_pointer() procedure. Also, create a
3421 gfc_formal_arglist for the SHAPE and add it to the provided
3425 gen_shape_param (gfc_formal_arglist
**head
,
3426 gfc_formal_arglist
**tail
,
3427 const char *module_name
,
3428 gfc_namespace
*ns
, const char *shape_param_name
)
3430 gfc_symbol
*param_sym
= NULL
;
3431 gfc_symtree
*param_symtree
= NULL
;
3432 gfc_formal_arglist
*formal_arg
= NULL
;
3433 const char *shape_param
= "gfc_shape_array__";
3436 if (shape_param_name
!= NULL
)
3437 shape_param
= shape_param_name
;
3439 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3440 if (param_symtree
!= NULL
)
3441 param_sym
= param_symtree
->n
.sym
;
3443 gfc_internal_error ("generateShapeParam(): Unable to "
3444 "create symbol for %s", shape_param
);
3446 /* Set up the necessary fields for the shape input param sym. */
3448 param_sym
->attr
.dummy
= 1;
3449 param_sym
->attr
.use_assoc
= 1;
3451 /* Integer array, rank 1, describing the shape of the object. Make it's
3452 type BT_VOID initially so we can accept any type/kind combination of
3453 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3454 of BT_INTEGER type. */
3455 param_sym
->ts
.type
= BT_VOID
;
3457 /* Initialize the kind to default integer. However, it will be overriden
3458 during resolution to match the kind of the SHAPE parameter given as
3459 the actual argument (to allow for any valid integer kind). */
3460 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3461 param_sym
->as
= gfc_get_array_spec ();
3463 /* Clear out the dimension info for the array. */
3464 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3466 param_sym
->as
->lower
[i
] = NULL
;
3467 param_sym
->as
->upper
[i
] = NULL
;
3469 param_sym
->as
->rank
= 1;
3470 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3472 /* The extent is unknown until we get it. The length give us
3473 the rank the incoming pointer. */
3474 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3476 /* The arg is also optional; it is required iff the second arg
3477 (fptr) is to an array, otherwise, it's ignored. */
3478 param_sym
->attr
.optional
= 1;
3479 param_sym
->attr
.intent
= INTENT_IN
;
3480 param_sym
->attr
.dimension
= 1;
3481 param_sym
->module
= gfc_get_string (module_name
);
3484 formal_arg
= gfc_get_formal_arglist ();
3485 /* Add arg to list of formal args. */
3486 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3489 /* Add a procedure interface to the given symbol (i.e., store a
3490 reference to the list of formal arguments). */
3493 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3494 gfc_formal_arglist
*formal
)
3497 sym
->formal
= formal
;
3498 sym
->attr
.if_source
= source
;
3502 /* Builds the parameter list for the iso_c_binding procedure
3503 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3504 generic version of either the c_f_pointer or c_f_procpointer
3505 functions. The new_proc_sym represents a "resolved" version of the
3506 symbol. The functions are resolved to match the types of their
3507 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3508 something similar to c_f_pointer_i4 if the type of data object fptr
3509 pointed to was a default integer. The actual name of the resolved
3510 procedure symbol is further mangled with the module name, etc., but
3511 the idea holds true. */
3514 build_formal_args (gfc_symbol
*new_proc_sym
,
3515 gfc_symbol
*old_sym
, int add_optional_arg
)
3517 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3518 gfc_namespace
*parent_ns
= NULL
;
3520 parent_ns
= gfc_current_ns
;
3521 /* Create a new namespace, which will be the formal ns (namespace
3522 of the formal args). */
3523 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3524 gfc_current_ns
->proc_name
= new_proc_sym
;
3526 /* Generate the params. */
3527 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3528 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3530 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3531 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3532 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3533 gfc_current_ns
, "fptr");
3535 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3536 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3538 gen_shape_param (&head
, &tail
,
3539 (const char *) new_proc_sym
->module
,
3540 gfc_current_ns
, "shape");
3543 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3545 /* c_associated has one required arg and one optional; both
3547 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3548 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3549 if (add_optional_arg
)
3551 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3552 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3553 /* The last param is optional so mark it as such. */
3554 tail
->sym
->attr
.optional
= 1;
3558 /* Add the interface (store formal args to new_proc_sym). */
3559 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3561 /* Set up the formal_ns pointer to the one created for the
3562 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3563 new_proc_sym
->formal_ns
= gfc_current_ns
;
3565 gfc_current_ns
= parent_ns
;
3569 /* Generate the given set of C interoperable kind objects, or all
3570 interoperable kinds. This function will only be given kind objects
3571 for valid iso_c_binding defined types because this is verified when
3572 the 'use' statement is parsed. If the user gives an 'only' clause,
3573 the specific kinds are looked up; if they don't exist, an error is
3574 reported. If the user does not give an 'only' clause, all
3575 iso_c_binding symbols are generated. If a list of specific kinds
3576 is given, it must have a NULL in the first empty spot to mark the
3581 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3584 char *name
= (local_name
&& local_name
[0]) ? local_name
3585 : c_interop_kinds_table
[s
].name
;
3586 gfc_symtree
*tmp_symtree
= NULL
;
3587 gfc_symbol
*tmp_sym
= NULL
;
3588 gfc_dt_list
**dt_list_ptr
= NULL
;
3589 gfc_component
*tmp_comp
= NULL
;
3590 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3593 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3595 /* Already exists in this scope so don't re-add it.
3596 TODO: we should probably check that it's really the same symbol. */
3597 if (tmp_symtree
!= NULL
)
3600 /* Create the sym tree in the current ns. */
3601 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3603 tmp_sym
= tmp_symtree
->n
.sym
;
3605 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3608 /* Say what module this symbol belongs to. */
3609 tmp_sym
->module
= gfc_get_string (mod_name
);
3610 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3611 tmp_sym
->intmod_sym_id
= s
;
3616 #define NAMED_INTCST(a,b,c) case a :
3617 #define NAMED_REALCST(a,b,c) case a :
3618 #define NAMED_CMPXCST(a,b,c) case a :
3619 #define NAMED_LOGCST(a,b,c) case a :
3620 #define NAMED_CHARKNDCST(a,b,c) case a :
3621 #include "iso-c-binding.def"
3623 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3625 /* Initialize an integer constant expression node. */
3626 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3627 tmp_sym
->ts
.type
= BT_INTEGER
;
3628 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3630 /* Mark this type as a C interoperable one. */
3631 tmp_sym
->ts
.is_c_interop
= 1;
3632 tmp_sym
->ts
.is_iso_c
= 1;
3633 tmp_sym
->value
->ts
.is_c_interop
= 1;
3634 tmp_sym
->value
->ts
.is_iso_c
= 1;
3635 tmp_sym
->attr
.is_c_interop
= 1;
3637 /* Tell what f90 type this c interop kind is valid. */
3638 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3640 /* Say it's from the iso_c_binding module. */
3641 tmp_sym
->attr
.is_iso_c
= 1;
3643 /* Make it use associated. */
3644 tmp_sym
->attr
.use_assoc
= 1;
3648 #define NAMED_CHARCST(a,b,c) case a :
3649 #include "iso-c-binding.def"
3651 /* Initialize an integer constant expression node for the
3652 length of the character. */
3653 tmp_sym
->value
= gfc_get_expr ();
3654 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3655 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3656 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3657 tmp_sym
->value
->where
= gfc_current_locus
;
3658 tmp_sym
->value
->ts
.is_c_interop
= 1;
3659 tmp_sym
->value
->ts
.is_iso_c
= 1;
3660 tmp_sym
->value
->value
.character
.length
= 1;
3661 tmp_sym
->value
->value
.character
.string
= gfc_getmem (2);
3662 tmp_sym
->value
->value
.character
.string
[0]
3663 = (char) c_interop_kinds_table
[s
].value
;
3664 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3666 /* May not need this in both attr and ts, but do need in
3667 attr for writing module file. */
3668 tmp_sym
->attr
.is_c_interop
= 1;
3670 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3671 tmp_sym
->ts
.type
= BT_CHARACTER
;
3673 /* Need to set it to the C_CHAR kind. */
3674 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3676 /* Mark this type as a C interoperable one. */
3677 tmp_sym
->ts
.is_c_interop
= 1;
3678 tmp_sym
->ts
.is_iso_c
= 1;
3680 /* Tell what f90 type this c interop kind is valid. */
3681 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3683 /* Say it's from the iso_c_binding module. */
3684 tmp_sym
->attr
.is_iso_c
= 1;
3686 /* Make it use associated. */
3687 tmp_sym
->attr
.use_assoc
= 1;
3690 case ISOCBINDING_PTR
:
3691 case ISOCBINDING_FUNPTR
:
3693 /* Initialize an integer constant expression node. */
3694 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3695 tmp_sym
->ts
.is_c_interop
= 1;
3696 tmp_sym
->attr
.is_c_interop
= 1;
3697 tmp_sym
->attr
.is_iso_c
= 1;
3698 tmp_sym
->ts
.is_iso_c
= 1;
3699 tmp_sym
->ts
.type
= BT_DERIVED
;
3701 /* A derived type must have the bind attribute to be
3702 interoperable (J3/04-007, Section 15.2.3), even though
3703 the binding label is not used. */
3704 tmp_sym
->attr
.is_bind_c
= 1;
3706 tmp_sym
->attr
.referenced
= 1;
3708 tmp_sym
->ts
.derived
= tmp_sym
;
3710 /* Add the symbol created for the derived type to the current ns. */
3711 dt_list_ptr
= &(gfc_derived_types
);
3712 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3713 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3715 /* There is already at least one derived type in the list, so append
3716 the one we're currently building for c_ptr or c_funptr. */
3717 if (*dt_list_ptr
!= NULL
)
3718 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3719 (*dt_list_ptr
) = gfc_get_dt_list ();
3720 (*dt_list_ptr
)->derived
= tmp_sym
;
3721 (*dt_list_ptr
)->next
= NULL
;
3723 /* Set up the component of the derived type, which will be
3724 an integer with kind equal to c_ptr_size. Mangle the name of
3725 the field for the c_address to prevent the curious user from
3726 trying to access it from Fortran. */
3727 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3728 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3729 if (tmp_comp
== NULL
)
3730 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3731 "create component for c_address");
3733 tmp_comp
->ts
.type
= BT_INTEGER
;
3735 /* Set this because the module will need to read/write this field. */
3736 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3738 /* The kinds for c_ptr and c_funptr are the same. */
3739 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3740 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3742 tmp_comp
->pointer
= 0;
3743 tmp_comp
->dimension
= 0;
3745 /* Mark the component as C interoperable. */
3746 tmp_comp
->ts
.is_c_interop
= 1;
3748 /* Make it use associated (iso_c_binding module). */
3749 tmp_sym
->attr
.use_assoc
= 1;
3752 case ISOCBINDING_NULL_PTR
:
3753 case ISOCBINDING_NULL_FUNPTR
:
3754 gen_special_c_interop_ptr (s
, name
, mod_name
);
3757 case ISOCBINDING_F_POINTER
:
3758 case ISOCBINDING_ASSOCIATED
:
3759 case ISOCBINDING_LOC
:
3760 case ISOCBINDING_FUNLOC
:
3761 case ISOCBINDING_F_PROCPOINTER
:
3763 tmp_sym
->attr
.proc
= PROC_MODULE
;
3765 /* Use the procedure's name as it is in the iso_c_binding module for
3766 setting the binding label in case the user renamed the symbol. */
3767 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3768 c_interop_kinds_table
[s
].name
);
3769 tmp_sym
->attr
.is_iso_c
= 1;
3770 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3771 tmp_sym
->attr
.subroutine
= 1;
3774 /* TODO! This needs to be finished more for the expr of the
3775 function or something!
3776 This may not need to be here, because trying to do c_loc
3778 if (s
== ISOCBINDING_ASSOCIATED
)
3780 tmp_sym
->attr
.function
= 1;
3781 tmp_sym
->ts
.type
= BT_LOGICAL
;
3782 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3783 tmp_sym
->result
= tmp_sym
;
3787 /* Here, we're taking the simple approach. We're defining
3788 c_loc as an external identifier so the compiler will put
3789 what we expect on the stack for the address we want the
3791 tmp_sym
->ts
.type
= BT_DERIVED
;
3792 if (s
== ISOCBINDING_LOC
)
3793 tmp_sym
->ts
.derived
=
3794 get_iso_c_binding_dt (ISOCBINDING_PTR
);
3796 tmp_sym
->ts
.derived
=
3797 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3799 if (tmp_sym
->ts
.derived
== NULL
)
3801 /* Create the necessary derived type so we can continue
3802 processing the file. */
3803 generate_isocbinding_symbol
3804 (mod_name
, s
== ISOCBINDING_FUNLOC
3805 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
3806 (char *)(s
== ISOCBINDING_FUNLOC
3807 ? "_gfortran_iso_c_binding_c_funptr"
3808 : "_gfortran_iso_c_binding_c_ptr"));
3809 tmp_sym
->ts
.derived
=
3810 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
3811 ? ISOCBINDING_FUNPTR
3815 /* The function result is itself (no result clause). */
3816 tmp_sym
->result
= tmp_sym
;
3817 tmp_sym
->attr
.external
= 1;
3818 tmp_sym
->attr
.use_assoc
= 0;
3819 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
3820 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
3824 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
3825 tmp_sym
->attr
.contained
= 0;
3827 /* Try using this builder routine, with the new and old symbols
3828 both being the generic iso_c proc sym being created. This
3829 will create the formal args (and the new namespace for them).
3830 Don't build an arg list for c_loc because we're going to treat
3831 c_loc as an external procedure. */
3832 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
3833 /* The 1 says to add any optional args, if applicable. */
3834 build_formal_args (tmp_sym
, tmp_sym
, 1);
3836 /* Set this after setting up the symbol, to prevent error messages. */
3837 tmp_sym
->attr
.use_assoc
= 1;
3839 /* This symbol will not be referenced directly. It will be
3840 resolved to the implementation for the given f90 kind. */
3841 tmp_sym
->attr
.referenced
= 0;
3851 /* Creates a new symbol based off of an old iso_c symbol, with a new
3852 binding label. This function can be used to create a new,
3853 resolved, version of a procedure symbol for c_f_pointer or
3854 c_f_procpointer that is based on the generic symbols. A new
3855 parameter list is created for the new symbol using
3856 build_formal_args(). The add_optional_flag specifies whether the
3857 to add the optional SHAPE argument. The new symbol is
3861 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
3862 char *new_binding_label
, int add_optional_arg
)
3864 gfc_symtree
*new_symtree
= NULL
;
3866 /* See if we have a symbol by that name already available, looking
3867 through any parent namespaces. */
3868 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
3869 if (new_symtree
!= NULL
)
3870 /* Return the existing symbol. */
3871 return new_symtree
->n
.sym
;
3873 /* Create the symtree/symbol, with attempted host association. */
3874 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
3875 if (new_symtree
== NULL
)
3876 gfc_internal_error ("get_iso_c_sym(): Unable to create "
3877 "symtree for '%s'", new_name
);
3879 /* Now fill in the fields of the resolved symbol with the old sym. */
3880 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
3881 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
3882 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
3883 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
3884 /* Build the formal arg list. */
3885 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
3887 gfc_commit_symbol (new_symtree
->n
.sym
);
3889 return new_symtree
->n
.sym
;