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
)
83 /* This is to make sure the backend generates setup code in the correct
86 static int next_dummy_order
= 1;
89 gfc_namespace
*gfc_current_ns
;
91 gfc_gsymbol
*gfc_gsym_root
= NULL
;
93 static gfc_symbol
*changed_syms
= NULL
;
95 gfc_dt_list
*gfc_derived_types
;
98 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
100 /* The following static variable indicates whether a particular element has
101 been explicitly set or not. */
103 static int new_flag
[GFC_LETTERS
];
106 /* Handle a correctly parsed IMPLICIT NONE. */
109 gfc_set_implicit_none (void)
113 if (gfc_current_ns
->seen_implicit_none
)
115 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
119 gfc_current_ns
->seen_implicit_none
= 1;
121 for (i
= 0; i
< GFC_LETTERS
; i
++)
123 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
124 gfc_current_ns
->set_flag
[i
] = 1;
129 /* Reset the implicit range flags. */
132 gfc_clear_new_implicit (void)
136 for (i
= 0; i
< GFC_LETTERS
; i
++)
141 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
144 gfc_add_new_implicit_range (int c1
, int c2
)
151 for (i
= c1
; i
<= c2
; i
++)
155 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
167 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
168 the new implicit types back into the existing types will work. */
171 gfc_merge_new_implicit (gfc_typespec
*ts
)
175 if (gfc_current_ns
->seen_implicit_none
)
177 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
181 for (i
= 0; i
< GFC_LETTERS
; i
++)
186 if (gfc_current_ns
->set_flag
[i
])
188 gfc_error ("Letter %c already has an IMPLICIT type at %C",
192 gfc_current_ns
->default_type
[i
] = *ts
;
193 gfc_current_ns
->set_flag
[i
] = 1;
200 /* Given a symbol, return a pointer to the typespec for its default type. */
203 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
207 letter
= sym
->name
[0];
209 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
210 gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
211 "gfortran developers, and should not be used for "
212 "implicitly typed variables");
214 if (letter
< 'a' || letter
> 'z')
215 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
220 return &ns
->default_type
[letter
- 'a'];
224 /* Given a pointer to a symbol, set its type according to the first
225 letter of its name. Fails if the letter in question has no default
229 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
233 if (sym
->ts
.type
!= BT_UNKNOWN
)
234 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
236 ts
= gfc_get_default_type (sym
, ns
);
238 if (ts
->type
== BT_UNKNOWN
)
240 if (error_flag
&& !sym
->attr
.untyped
)
242 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
243 sym
->name
, &sym
->declared_at
);
244 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
251 sym
->attr
.implicit_type
= 1;
253 if (sym
->attr
.is_bind_c
== 1)
255 /* BIND(C) variables should not be implicitly declared. */
256 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
257 "not be C interoperable", sym
->name
, &sym
->declared_at
);
258 sym
->ts
.f90_type
= sym
->ts
.type
;
261 if (sym
->attr
.dummy
!= 0)
263 if (sym
->ns
->proc_name
!= NULL
264 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
265 || sym
->ns
->proc_name
->attr
.function
!= 0)
266 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
268 /* Dummy args to a BIND(C) routine may not be interoperable if
269 they are implicitly typed. */
270 gfc_warning_now ("Implicity declared variable '%s' at %L may not "
271 "be C interoperable but it is a dummy argument to "
272 "the BIND(C) procedure '%s' at %L", sym
->name
,
273 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
274 &(sym
->ns
->proc_name
->declared_at
));
275 sym
->ts
.f90_type
= sym
->ts
.type
;
283 /* This function is called from parse.c(parse_progunit) to check the
284 type of the function is not implicitly typed in the host namespace
285 and to implicitly type the function result, if necessary. */
288 gfc_check_function_type (gfc_namespace
*ns
)
290 gfc_symbol
*proc
= ns
->proc_name
;
292 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
295 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
297 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
300 if (proc
->result
!= proc
)
302 proc
->ts
= proc
->result
->ts
;
303 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
304 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
305 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
306 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
311 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
312 proc
->result
->name
, &proc
->result
->declared_at
);
313 proc
->result
->attr
.untyped
= 1;
319 /******************** Symbol attribute stuff *********************/
321 /* This is a generic conflict-checker. We do this to avoid having a
322 single conflict in two places. */
324 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
325 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
326 #define conf_std(a, b, std) if (attr->a && attr->b)\
335 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
337 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
338 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
339 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
340 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
341 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
342 *private = "PRIVATE", *recursive
= "RECURSIVE",
343 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
344 *public = "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
345 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
346 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
347 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
348 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
349 *volatile_
= "VOLATILE", *protected = "PROTECTED",
350 *is_bind_c
= "BIND(C)";
351 static const char *threadprivate
= "THREADPRIVATE";
357 where
= &gfc_current_locus
;
359 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
363 standard
= GFC_STD_F2003
;
367 /* Check for attributes not allowed in a BLOCK DATA. */
368 if (gfc_current_state () == COMP_BLOCK_DATA
)
372 if (attr
->in_namelist
)
374 if (attr
->allocatable
)
380 if (attr
->access
== ACCESS_PRIVATE
)
382 if (attr
->access
== ACCESS_PUBLIC
)
384 if (attr
->intent
!= INTENT_UNKNOWN
)
390 ("%s attribute not allowed in BLOCK DATA program unit at %L",
397 conf (dummy
, intrinsic
);
399 conf (dummy
, threadprivate
);
400 conf (pointer
, target
);
401 conf (pointer
, intrinsic
);
402 conf (pointer
, elemental
);
403 conf (allocatable
, elemental
);
405 conf (target
, external
);
406 conf (target
, intrinsic
);
407 conf (external
, dimension
); /* See Fortran 95's R504. */
409 conf (external
, intrinsic
);
411 if (attr
->if_source
|| attr
->contained
)
413 conf (external
, subroutine
);
414 conf (external
, function
);
417 conf (allocatable
, pointer
);
418 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
419 conf_std (allocatable
, function
, GFC_STD_F2003
);
420 conf_std (allocatable
, result
, GFC_STD_F2003
);
421 conf (elemental
, recursive
);
423 conf (in_common
, dummy
);
424 conf (in_common
, allocatable
);
425 conf (in_common
, result
);
426 conf (in_common
, save
);
429 conf (dummy
, result
);
431 conf (in_equivalence
, use_assoc
);
432 conf (in_equivalence
, dummy
);
433 conf (in_equivalence
, target
);
434 conf (in_equivalence
, pointer
);
435 conf (in_equivalence
, function
);
436 conf (in_equivalence
, result
);
437 conf (in_equivalence
, entry
);
438 conf (in_equivalence
, allocatable
);
439 conf (in_equivalence
, threadprivate
);
441 conf (in_namelist
, pointer
);
442 conf (in_namelist
, allocatable
);
444 conf (entry
, result
);
446 conf (function
, subroutine
);
448 if (!function
&& !subroutine
)
449 conf (is_bind_c
, dummy
);
451 conf (is_bind_c
, cray_pointer
);
452 conf (is_bind_c
, cray_pointee
);
453 conf (is_bind_c
, allocatable
);
455 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
456 Parameter conflict caught below. Also, value cannot be specified
457 for a dummy procedure. */
459 /* Cray pointer/pointee conflicts. */
460 conf (cray_pointer
, cray_pointee
);
461 conf (cray_pointer
, dimension
);
462 conf (cray_pointer
, pointer
);
463 conf (cray_pointer
, target
);
464 conf (cray_pointer
, allocatable
);
465 conf (cray_pointer
, external
);
466 conf (cray_pointer
, intrinsic
);
467 conf (cray_pointer
, in_namelist
);
468 conf (cray_pointer
, function
);
469 conf (cray_pointer
, subroutine
);
470 conf (cray_pointer
, entry
);
472 conf (cray_pointee
, allocatable
);
473 conf (cray_pointee
, intent
);
474 conf (cray_pointee
, optional
);
475 conf (cray_pointee
, dummy
);
476 conf (cray_pointee
, target
);
477 conf (cray_pointee
, intrinsic
);
478 conf (cray_pointee
, pointer
);
479 conf (cray_pointee
, entry
);
480 conf (cray_pointee
, in_common
);
481 conf (cray_pointee
, in_equivalence
);
482 conf (cray_pointee
, threadprivate
);
485 conf (data
, function
);
487 conf (data
, allocatable
);
488 conf (data
, use_assoc
);
490 conf (value
, pointer
)
491 conf (value
, allocatable
)
492 conf (value
, subroutine
)
493 conf (value
, function
)
494 conf (value
, volatile_
)
495 conf (value
, dimension
)
496 conf (value
, external
)
499 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
502 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
506 conf (protected, intrinsic
)
507 conf (protected, external
)
508 conf (protected, in_common
)
510 conf (volatile_
, intrinsic
)
511 conf (volatile_
, external
)
513 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
520 a1
= gfc_code2string (flavors
, attr
->flavor
);
522 if (attr
->in_namelist
523 && attr
->flavor
!= FL_VARIABLE
524 && attr
->flavor
!= FL_PROCEDURE
525 && attr
->flavor
!= FL_UNKNOWN
)
531 switch (attr
->flavor
)
552 conf2 (threadprivate
);
563 if (attr
->subroutine
)
572 conf2 (threadprivate
);
577 case PROC_ST_FUNCTION
:
590 conf2 (threadprivate
);
611 conf2 (threadprivate
);
613 if (attr
->intent
!= INTENT_UNKNOWN
)
636 conf2 (threadprivate
);
637 /* TODO: hmm, double check this. */
649 gfc_error ("%s attribute conflicts with %s attribute at %L",
652 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
653 a1
, a2
, name
, where
);
660 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
661 "with %s attribute at %L", a1
, a2
,
666 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
667 "with %s attribute in '%s' at %L",
668 a1
, a2
, name
, where
);
677 /* Mark a symbol as referenced. */
680 gfc_set_sym_referenced (gfc_symbol
*sym
)
683 if (sym
->attr
.referenced
)
686 sym
->attr
.referenced
= 1;
688 /* Remember which order dummy variables are accessed in. */
690 sym
->dummy_order
= next_dummy_order
++;
694 /* Common subroutine called by attribute changing subroutines in order
695 to prevent them from changing a symbol that has been
696 use-associated. Returns zero if it is OK to change the symbol,
700 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
703 if (attr
->use_assoc
== 0)
707 where
= &gfc_current_locus
;
710 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
713 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
720 /* Generate an error because of a duplicate attribute. */
723 duplicate_attr (const char *attr
, locus
*where
)
727 where
= &gfc_current_locus
;
729 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
733 /* Called from decl.c (attr_decl1) to check attributes, when declared
737 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
740 if (check_used (attr
, NULL
, where
))
743 return check_conflict (attr
, NULL
, where
);
747 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
750 if (check_used (attr
, NULL
, where
))
753 if (attr
->allocatable
)
755 duplicate_attr ("ALLOCATABLE", where
);
759 attr
->allocatable
= 1;
760 return check_conflict (attr
, NULL
, where
);
765 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
768 if (check_used (attr
, name
, where
))
773 duplicate_attr ("DIMENSION", where
);
778 return check_conflict (attr
, name
, where
);
783 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
786 if (check_used (attr
, NULL
, where
))
791 duplicate_attr ("EXTERNAL", where
);
797 return check_conflict (attr
, NULL
, where
);
802 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
805 if (check_used (attr
, NULL
, where
))
810 duplicate_attr ("INTRINSIC", where
);
816 return check_conflict (attr
, NULL
, where
);
821 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
824 if (check_used (attr
, NULL
, where
))
829 duplicate_attr ("OPTIONAL", where
);
834 return check_conflict (attr
, NULL
, where
);
839 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
842 if (check_used (attr
, NULL
, where
))
846 return check_conflict (attr
, NULL
, where
);
851 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
854 if (check_used (attr
, NULL
, where
))
857 attr
->cray_pointer
= 1;
858 return check_conflict (attr
, NULL
, where
);
863 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
866 if (check_used (attr
, NULL
, where
))
869 if (attr
->cray_pointee
)
871 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
872 " statements", where
);
876 attr
->cray_pointee
= 1;
877 return check_conflict (attr
, NULL
, where
);
882 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
884 if (check_used (attr
, name
, where
))
889 if (gfc_notify_std (GFC_STD_LEGACY
,
890 "Duplicate PROTECTED attribute specified at %L",
897 return check_conflict (attr
, name
, where
);
902 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
905 if (check_used (attr
, name
, where
))
909 return check_conflict (attr
, name
, where
);
914 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
917 if (check_used (attr
, name
, where
))
923 ("SAVE attribute at %L cannot be specified in a PURE procedure",
930 if (gfc_notify_std (GFC_STD_LEGACY
,
931 "Duplicate SAVE attribute specified at %L",
938 return check_conflict (attr
, name
, where
);
943 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
946 if (check_used (attr
, name
, where
))
951 if (gfc_notify_std (GFC_STD_LEGACY
,
952 "Duplicate VALUE attribute specified at %L",
959 return check_conflict (attr
, name
, where
);
964 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
966 /* No check_used needed as 11.2.1 of the F2003 standard allows
967 that the local identifier made accessible by a use statement can be
968 given a VOLATILE attribute. */
970 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
971 if (gfc_notify_std (GFC_STD_LEGACY
,
972 "Duplicate VOLATILE attribute specified at %L", where
)
977 attr
->volatile_ns
= gfc_current_ns
;
978 return check_conflict (attr
, name
, where
);
983 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
986 if (check_used (attr
, name
, where
))
989 if (attr
->threadprivate
)
991 duplicate_attr ("THREADPRIVATE", where
);
995 attr
->threadprivate
= 1;
996 return check_conflict (attr
, name
, where
);
1001 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1004 if (check_used (attr
, NULL
, where
))
1009 duplicate_attr ("TARGET", where
);
1014 return check_conflict (attr
, NULL
, where
);
1019 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1022 if (check_used (attr
, name
, where
))
1025 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1027 return check_conflict (attr
, name
, where
);
1032 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1035 if (check_used (attr
, name
, where
))
1038 /* Duplicate attribute already checked for. */
1039 attr
->in_common
= 1;
1040 if (check_conflict (attr
, name
, where
) == FAILURE
)
1043 if (attr
->flavor
== FL_VARIABLE
)
1046 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1051 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1054 /* Duplicate attribute already checked for. */
1055 attr
->in_equivalence
= 1;
1056 if (check_conflict (attr
, name
, where
) == FAILURE
)
1059 if (attr
->flavor
== FL_VARIABLE
)
1062 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1067 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1070 if (check_used (attr
, name
, where
))
1074 return check_conflict (attr
, name
, where
);
1079 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1082 attr
->in_namelist
= 1;
1083 return check_conflict (attr
, name
, where
);
1088 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1091 if (check_used (attr
, name
, where
))
1095 return check_conflict (attr
, name
, where
);
1100 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1103 if (check_used (attr
, NULL
, where
))
1106 attr
->elemental
= 1;
1107 return check_conflict (attr
, NULL
, where
);
1112 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1115 if (check_used (attr
, NULL
, where
))
1119 return check_conflict (attr
, NULL
, where
);
1124 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1127 if (check_used (attr
, NULL
, where
))
1130 attr
->recursive
= 1;
1131 return check_conflict (attr
, NULL
, where
);
1136 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1139 if (check_used (attr
, name
, where
))
1144 duplicate_attr ("ENTRY", where
);
1149 return check_conflict (attr
, name
, where
);
1154 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1157 if (attr
->flavor
!= FL_PROCEDURE
1158 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1162 return check_conflict (attr
, name
, where
);
1167 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1170 if (attr
->flavor
!= FL_PROCEDURE
1171 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1174 attr
->subroutine
= 1;
1175 return check_conflict (attr
, name
, where
);
1180 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1183 if (attr
->flavor
!= FL_PROCEDURE
1184 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1188 return check_conflict (attr
, name
, where
);
1192 /* Flavors are special because some flavors are not what Fortran
1193 considers attributes and can be reaffirmed multiple times. */
1196 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1200 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1201 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1202 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1205 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1208 if (attr
->flavor
!= FL_UNKNOWN
)
1211 where
= &gfc_current_locus
;
1214 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1215 gfc_code2string (flavors
, attr
->flavor
), name
,
1216 gfc_code2string (flavors
, f
), where
);
1218 gfc_error ("%s attribute conflicts with %s attribute at %L",
1219 gfc_code2string (flavors
, attr
->flavor
),
1220 gfc_code2string (flavors
, f
), where
);
1227 return check_conflict (attr
, name
, where
);
1232 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1233 const char *name
, locus
*where
)
1236 if (check_used (attr
, name
, where
))
1239 if (attr
->flavor
!= FL_PROCEDURE
1240 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1244 where
= &gfc_current_locus
;
1246 if (attr
->proc
!= PROC_UNKNOWN
)
1248 gfc_error ("%s procedure at %L is already declared as %s procedure",
1249 gfc_code2string (procedures
, t
), where
,
1250 gfc_code2string (procedures
, attr
->proc
));
1257 /* Statement functions are always scalar and functions. */
1258 if (t
== PROC_ST_FUNCTION
1259 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1260 || attr
->dimension
))
1263 return check_conflict (attr
, name
, where
);
1268 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1271 if (check_used (attr
, NULL
, where
))
1274 if (attr
->intent
== INTENT_UNKNOWN
)
1276 attr
->intent
= intent
;
1277 return check_conflict (attr
, NULL
, where
);
1281 where
= &gfc_current_locus
;
1283 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1284 gfc_intent_string (attr
->intent
),
1285 gfc_intent_string (intent
), where
);
1291 /* No checks for use-association in public and private statements. */
1294 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1295 const char *name
, locus
*where
)
1298 if (attr
->access
== ACCESS_UNKNOWN
)
1300 attr
->access
= access
;
1301 return check_conflict (attr
, name
, where
);
1305 where
= &gfc_current_locus
;
1306 gfc_error ("ACCESS specification at %L was already specified", where
);
1312 /* Set the is_bind_c field for the given symbol_attribute. */
1315 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1316 int is_proc_lang_bind_spec
)
1319 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1320 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1321 "variables or common blocks", where
);
1322 else if (attr
->is_bind_c
)
1323 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1325 attr
->is_bind_c
= 1;
1328 where
= &gfc_current_locus
;
1330 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1334 return check_conflict (attr
, name
, where
);
1339 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1340 gfc_formal_arglist
* formal
, locus
*where
)
1343 if (check_used (&sym
->attr
, sym
->name
, where
))
1347 where
= &gfc_current_locus
;
1349 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1350 && sym
->attr
.if_source
!= IFSRC_DECL
)
1352 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1357 sym
->formal
= formal
;
1358 sym
->attr
.if_source
= source
;
1364 /* Add a type to a symbol. */
1367 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1372 where
= &gfc_current_locus
;
1374 if (sym
->ts
.type
!= BT_UNKNOWN
)
1376 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1377 if (!(sym
->ts
.type
== ts
->type
1378 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1379 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1382 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1385 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1386 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1390 flavor
= sym
->attr
.flavor
;
1392 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1393 || flavor
== FL_LABEL
1394 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1395 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1397 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1406 /* Clears all attributes. */
1409 gfc_clear_attr (symbol_attribute
*attr
)
1411 memset (attr
, 0, sizeof (symbol_attribute
));
1415 /* Check for missing attributes in the new symbol. Currently does
1416 nothing, but it's not clear that it is unnecessary yet. */
1419 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1420 locus
*where ATTRIBUTE_UNUSED
)
1427 /* Copy an attribute to a symbol attribute, bit by bit. Some
1428 attributes have a lot of side-effects but cannot be present given
1429 where we are called from, so we ignore some bits. */
1432 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1434 int is_proc_lang_bind_spec
;
1436 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1439 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1441 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1443 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1445 if (src
->protected && gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1447 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1449 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1451 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1453 if (src
->threadprivate
1454 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1456 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1458 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1460 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1465 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1468 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1471 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1473 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1475 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1478 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1480 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1482 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1484 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1487 if (src
->flavor
!= FL_UNKNOWN
1488 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1491 if (src
->intent
!= INTENT_UNKNOWN
1492 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1495 if (src
->access
!= ACCESS_UNKNOWN
1496 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1499 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1502 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1504 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1507 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1509 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1513 if (src
->is_c_interop
)
1514 dest
->is_c_interop
= 1;
1518 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1520 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1530 /************** Component name management ************/
1532 /* Component names of a derived type form their own little namespaces
1533 that are separate from all other spaces. The space is composed of
1534 a singly linked list of gfc_component structures whose head is
1535 located in the parent symbol. */
1538 /* Add a component name to a symbol. The call fails if the name is
1539 already present. On success, the component pointer is modified to
1540 point to the additional component structure. */
1543 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1544 gfc_component
**component
)
1546 gfc_component
*p
, *tail
;
1550 for (p
= sym
->components
; p
; p
= p
->next
)
1552 if (strcmp (p
->name
, name
) == 0)
1554 gfc_error ("Component '%s' at %C already declared at %L",
1562 /* Allocate a new component. */
1563 p
= gfc_get_component ();
1566 sym
->components
= p
;
1570 p
->name
= gfc_get_string (name
);
1571 p
->loc
= gfc_current_locus
;
1578 /* Recursive function to switch derived types of all symbol in a
1582 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1590 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1591 sym
->ts
.derived
= to
;
1593 switch_types (st
->left
, from
, to
);
1594 switch_types (st
->right
, from
, to
);
1598 /* This subroutine is called when a derived type is used in order to
1599 make the final determination about which version to use. The
1600 standard requires that a type be defined before it is 'used', but
1601 such types can appear in IMPLICIT statements before the actual
1602 definition. 'Using' in this context means declaring a variable to
1603 be that type or using the type constructor.
1605 If a type is used and the components haven't been defined, then we
1606 have to have a derived type in a parent unit. We find the node in
1607 the other namespace and point the symtree node in this namespace to
1608 that node. Further reference to this name point to the correct
1609 node. If we can't find the node in a parent namespace, then we have
1612 This subroutine takes a pointer to a symbol node and returns a
1613 pointer to the translated node or NULL for an error. Usually there
1614 is no translation and we return the node we were passed. */
1617 gfc_use_derived (gfc_symbol
*sym
)
1624 if (sym
->components
!= NULL
)
1625 return sym
; /* Already defined. */
1627 if (sym
->ns
->parent
== NULL
)
1630 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1632 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1636 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1639 /* Get rid of symbol sym, translating all references to s. */
1640 for (i
= 0; i
< GFC_LETTERS
; i
++)
1642 t
= &sym
->ns
->default_type
[i
];
1643 if (t
->derived
== sym
)
1647 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1652 /* Unlink from list of modified symbols. */
1653 gfc_commit_symbol (sym
);
1655 switch_types (sym
->ns
->sym_root
, sym
, s
);
1657 /* TODO: Also have to replace sym -> s in other lists like
1658 namelists, common lists and interface lists. */
1659 gfc_free_symbol (sym
);
1664 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1670 /* Given a derived type node and a component name, try to locate the
1671 component structure. Returns the NULL pointer if the component is
1672 not found or the components are private. */
1675 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1682 sym
= gfc_use_derived (sym
);
1687 for (p
= sym
->components
; p
; p
= p
->next
)
1688 if (strcmp (p
->name
, name
) == 0)
1692 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1696 if (sym
->attr
.use_assoc
&& (sym
->component_access
== ACCESS_PRIVATE
1697 || p
->access
== ACCESS_PRIVATE
))
1699 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1709 /* Given a symbol, free all of the component structures and everything
1713 free_components (gfc_component
*p
)
1721 gfc_free_array_spec (p
->as
);
1722 gfc_free_expr (p
->initializer
);
1729 /* Set component attributes from a standard symbol attribute structure. */
1732 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1735 c
->dimension
= attr
->dimension
;
1736 c
->pointer
= attr
->pointer
;
1737 c
->allocatable
= attr
->allocatable
;
1738 c
->access
= attr
->access
;
1742 /* Get a standard symbol attribute structure given the component
1746 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1749 gfc_clear_attr (attr
);
1750 attr
->dimension
= c
->dimension
;
1751 attr
->pointer
= c
->pointer
;
1752 attr
->allocatable
= c
->allocatable
;
1753 attr
->access
= c
->access
;
1757 /******************** Statement label management ********************/
1759 /* Comparison function for statement labels, used for managing the
1763 compare_st_labels (void *a1
, void *b1
)
1765 int a
= ((gfc_st_label
*) a1
)->value
;
1766 int b
= ((gfc_st_label
*) b1
)->value
;
1772 /* Free a single gfc_st_label structure, making sure the tree is not
1773 messed up. This function is called only when some parse error
1777 gfc_free_st_label (gfc_st_label
*label
)
1783 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1785 if (label
->format
!= NULL
)
1786 gfc_free_expr (label
->format
);
1792 /* Free a whole tree of gfc_st_label structures. */
1795 free_st_labels (gfc_st_label
*label
)
1801 free_st_labels (label
->left
);
1802 free_st_labels (label
->right
);
1804 if (label
->format
!= NULL
)
1805 gfc_free_expr (label
->format
);
1810 /* Given a label number, search for and return a pointer to the label
1811 structure, creating it if it does not exist. */
1814 gfc_get_st_label (int labelno
)
1818 /* First see if the label is already in this namespace. */
1819 lp
= gfc_current_ns
->st_labels
;
1822 if (lp
->value
== labelno
)
1825 if (lp
->value
< labelno
)
1831 lp
= gfc_getmem (sizeof (gfc_st_label
));
1833 lp
->value
= labelno
;
1834 lp
->defined
= ST_LABEL_UNKNOWN
;
1835 lp
->referenced
= ST_LABEL_UNKNOWN
;
1837 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
1843 /* Called when a statement with a statement label is about to be
1844 accepted. We add the label to the list of the current namespace,
1845 making sure it hasn't been defined previously and referenced
1849 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
1853 labelno
= lp
->value
;
1855 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1856 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
1857 &lp
->where
, label_locus
);
1860 lp
->where
= *label_locus
;
1864 case ST_LABEL_FORMAT
:
1865 if (lp
->referenced
== ST_LABEL_TARGET
)
1866 gfc_error ("Label %d at %C already referenced as branch target",
1869 lp
->defined
= ST_LABEL_FORMAT
;
1873 case ST_LABEL_TARGET
:
1874 if (lp
->referenced
== ST_LABEL_FORMAT
)
1875 gfc_error ("Label %d at %C already referenced as a format label",
1878 lp
->defined
= ST_LABEL_TARGET
;
1883 lp
->defined
= ST_LABEL_BAD_TARGET
;
1884 lp
->referenced
= ST_LABEL_BAD_TARGET
;
1890 /* Reference a label. Given a label and its type, see if that
1891 reference is consistent with what is known about that label,
1892 updating the unknown state. Returns FAILURE if something goes
1896 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
1898 gfc_sl_type label_type
;
1905 labelno
= lp
->value
;
1907 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
1908 label_type
= lp
->defined
;
1911 label_type
= lp
->referenced
;
1912 lp
->where
= gfc_current_locus
;
1915 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
1917 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
1922 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
1923 && type
== ST_LABEL_FORMAT
)
1925 gfc_error ("Label %d at %C previously used as branch target", labelno
);
1930 lp
->referenced
= type
;
1938 /************** Symbol table management subroutines ****************/
1940 /* Basic details: Fortran 95 requires a potentially unlimited number
1941 of distinct namespaces when compiling a program unit. This case
1942 occurs during a compilation of internal subprograms because all of
1943 the internal subprograms must be read before we can start
1944 generating code for the host.
1946 Given the tricky nature of the Fortran grammar, we must be able to
1947 undo changes made to a symbol table if the current interpretation
1948 of a statement is found to be incorrect. Whenever a symbol is
1949 looked up, we make a copy of it and link to it. All of these
1950 symbols are kept in a singly linked list so that we can commit or
1951 undo the changes at a later time.
1953 A symtree may point to a symbol node outside of its namespace. In
1954 this case, that symbol has been used as a host associated variable
1955 at some previous time. */
1957 /* Allocate a new namespace structure. Copies the implicit types from
1958 PARENT if PARENT_TYPES is set. */
1961 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
1965 gfc_intrinsic_op in
;
1968 ns
= gfc_getmem (sizeof (gfc_namespace
));
1969 ns
->sym_root
= NULL
;
1970 ns
->uop_root
= NULL
;
1971 ns
->default_access
= ACCESS_UNKNOWN
;
1972 ns
->parent
= parent
;
1974 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
1975 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
1977 /* Initialize default implicit types. */
1978 for (i
= 'a'; i
<= 'z'; i
++)
1980 ns
->set_flag
[i
- 'a'] = 0;
1981 ts
= &ns
->default_type
[i
- 'a'];
1983 if (parent_types
&& ns
->parent
!= NULL
)
1985 /* Copy parent settings. */
1986 *ts
= ns
->parent
->default_type
[i
- 'a'];
1990 if (gfc_option
.flag_implicit_none
!= 0)
1996 if ('i' <= i
&& i
<= 'n')
1998 ts
->type
= BT_INTEGER
;
1999 ts
->kind
= gfc_default_integer_kind
;
2004 ts
->kind
= gfc_default_real_kind
;
2014 /* Comparison function for symtree nodes. */
2017 compare_symtree (void *_st1
, void *_st2
)
2019 gfc_symtree
*st1
, *st2
;
2021 st1
= (gfc_symtree
*) _st1
;
2022 st2
= (gfc_symtree
*) _st2
;
2024 return strcmp (st1
->name
, st2
->name
);
2028 /* Allocate a new symtree node and associate it with the new symbol. */
2031 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2035 st
= gfc_getmem (sizeof (gfc_symtree
));
2036 st
->name
= gfc_get_string (name
);
2038 gfc_insert_bbt (root
, st
, compare_symtree
);
2043 /* Delete a symbol from the tree. Does not free the symbol itself! */
2046 delete_symtree (gfc_symtree
**root
, const char *name
)
2048 gfc_symtree st
, *st0
;
2050 st0
= gfc_find_symtree (*root
, name
);
2052 st
.name
= gfc_get_string (name
);
2053 gfc_delete_bbt (root
, &st
, compare_symtree
);
2059 /* Given a root symtree node and a name, try to find the symbol within
2060 the namespace. Returns NULL if the symbol is not found. */
2063 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2069 c
= strcmp (name
, st
->name
);
2073 st
= (c
< 0) ? st
->left
: st
->right
;
2080 /* Given a name find a user operator node, creating it if it doesn't
2081 exist. These are much simpler than symbols because they can't be
2082 ambiguous with one another. */
2085 gfc_get_uop (const char *name
)
2090 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2094 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2096 uop
= st
->n
.uop
= gfc_getmem (sizeof (gfc_user_op
));
2097 uop
->name
= gfc_get_string (name
);
2098 uop
->access
= ACCESS_UNKNOWN
;
2099 uop
->ns
= gfc_current_ns
;
2105 /* Given a name find the user operator node. Returns NULL if it does
2109 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2114 ns
= gfc_current_ns
;
2116 st
= gfc_find_symtree (ns
->uop_root
, name
);
2117 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2121 /* Remove a gfc_symbol structure and everything it points to. */
2124 gfc_free_symbol (gfc_symbol
*sym
)
2130 gfc_free_array_spec (sym
->as
);
2132 free_components (sym
->components
);
2134 gfc_free_expr (sym
->value
);
2136 gfc_free_namelist (sym
->namelist
);
2138 gfc_free_namespace (sym
->formal_ns
);
2140 if (!sym
->attr
.generic_copy
)
2141 gfc_free_interface (sym
->generic
);
2143 gfc_free_formal_arglist (sym
->formal
);
2149 /* Allocate and initialize a new symbol node. */
2152 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2156 p
= gfc_getmem (sizeof (gfc_symbol
));
2158 gfc_clear_ts (&p
->ts
);
2159 gfc_clear_attr (&p
->attr
);
2162 p
->declared_at
= gfc_current_locus
;
2164 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2165 gfc_internal_error ("new_symbol(): Symbol name too long");
2167 p
->name
= gfc_get_string (name
);
2169 /* Make sure flags for symbol being C bound are clear initially. */
2170 p
->attr
.is_bind_c
= 0;
2171 p
->attr
.is_iso_c
= 0;
2172 /* Make sure the binding label field has a Nul char to start. */
2173 p
->binding_label
[0] = '\0';
2175 /* Clear the ptrs we may need. */
2176 p
->common_block
= NULL
;
2182 /* Generate an error if a symbol is ambiguous. */
2185 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2188 if (st
->n
.sym
->module
)
2189 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2190 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2192 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2193 "from current program unit", name
, st
->n
.sym
->name
);
2197 /* Search for a symtree starting in the current namespace, resorting to
2198 any parent namespaces if requested by a nonzero parent_flag.
2199 Returns nonzero if the name is ambiguous. */
2202 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2203 gfc_symtree
**result
)
2208 ns
= gfc_current_ns
;
2212 st
= gfc_find_symtree (ns
->sym_root
, name
);
2216 /* Ambiguous generic interfaces are permitted, as long
2217 as the specific interfaces are different. */
2218 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2220 ambiguous_symbol (name
, st
);
2239 /* Same, but returns the symbol instead. */
2242 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2243 gfc_symbol
**result
)
2248 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2253 *result
= st
->n
.sym
;
2259 /* Save symbol with the information necessary to back it out. */
2262 save_symbol_data (gfc_symbol
*sym
)
2265 if (sym
->new || sym
->old_symbol
!= NULL
)
2268 sym
->old_symbol
= gfc_getmem (sizeof (gfc_symbol
));
2269 *(sym
->old_symbol
) = *sym
;
2271 sym
->tlink
= changed_syms
;
2276 /* Given a name, find a symbol, or create it if it does not exist yet
2277 in the current namespace. If the symbol is found we make sure that
2280 The integer return code indicates
2282 1 The symbol name was ambiguous
2283 2 The name meant to be established was already host associated.
2285 So if the return value is nonzero, then an error was issued. */
2288 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2293 /* This doesn't usually happen during resolution. */
2295 ns
= gfc_current_ns
;
2297 /* Try to find the symbol in ns. */
2298 st
= gfc_find_symtree (ns
->sym_root
, name
);
2302 /* If not there, create a new symbol. */
2303 p
= gfc_new_symbol (name
, ns
);
2305 /* Add to the list of tentative symbols. */
2306 p
->old_symbol
= NULL
;
2307 p
->tlink
= changed_syms
;
2312 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2319 /* Make sure the existing symbol is OK. Ambiguous
2320 generic interfaces are permitted, as long as the
2321 specific interfaces are different. */
2322 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2324 ambiguous_symbol (name
, st
);
2330 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
))
2332 /* Symbol is from another namespace. */
2333 gfc_error ("Symbol '%s' at %C has already been host associated",
2340 /* Copy in case this symbol is changed. */
2341 save_symbol_data (p
);
2350 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2355 i
= gfc_get_sym_tree (name
, ns
, &st
);
2360 *result
= st
->n
.sym
;
2367 /* Subroutine that searches for a symbol, creating it if it doesn't
2368 exist, but tries to host-associate the symbol if possible. */
2371 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2376 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2379 save_symbol_data (st
->n
.sym
);
2384 if (gfc_current_ns
->parent
!= NULL
)
2386 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2397 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2402 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2407 i
= gfc_get_ha_sym_tree (name
, &st
);
2410 *result
= st
->n
.sym
;
2417 /* Return true if both symbols could refer to the same data object. Does
2418 not take account of aliasing due to equivalence statements. */
2421 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2423 /* Aliasing isn't possible if the symbols have different base types. */
2424 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2427 /* Pointers can point to other pointers, target objects and allocatable
2428 objects. Two allocatable objects cannot share the same storage. */
2429 if (lsym
->attr
.pointer
2430 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2432 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2434 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2441 /* Undoes all the changes made to symbols in the current statement.
2442 This subroutine is made simpler due to the fact that attributes are
2443 never removed once added. */
2446 gfc_undo_symbols (void)
2448 gfc_symbol
*p
, *q
, *old
;
2450 for (p
= changed_syms
; p
; p
= q
)
2456 /* Symbol was new. */
2457 delete_symtree (&p
->ns
->sym_root
, p
->name
);
2461 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2463 gfc_free_symbol (p
);
2467 /* Restore previous state of symbol. Just copy simple stuff. */
2469 old
= p
->old_symbol
;
2471 p
->ts
.type
= old
->ts
.type
;
2472 p
->ts
.kind
= old
->ts
.kind
;
2474 p
->attr
= old
->attr
;
2476 if (p
->value
!= old
->value
)
2478 gfc_free_expr (old
->value
);
2482 if (p
->as
!= old
->as
)
2485 gfc_free_array_spec (p
->as
);
2489 p
->generic
= old
->generic
;
2490 p
->component_access
= old
->component_access
;
2492 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2494 gfc_free_namelist (p
->namelist
);
2499 if (p
->namelist_tail
!= old
->namelist_tail
)
2501 gfc_free_namelist (old
->namelist_tail
);
2502 old
->namelist_tail
->next
= NULL
;
2506 p
->namelist_tail
= old
->namelist_tail
;
2508 if (p
->formal
!= old
->formal
)
2510 gfc_free_formal_arglist (p
->formal
);
2511 p
->formal
= old
->formal
;
2514 gfc_free (p
->old_symbol
);
2515 p
->old_symbol
= NULL
;
2519 changed_syms
= NULL
;
2523 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2524 components of old_symbol that might need deallocation are the "allocatables"
2525 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2526 namelist_tail. In case these differ between old_symbol and sym, it's just
2527 because sym->namelist has gotten a few more items. */
2530 free_old_symbol (gfc_symbol
*sym
)
2533 if (sym
->old_symbol
== NULL
)
2536 if (sym
->old_symbol
->as
!= sym
->as
)
2537 gfc_free_array_spec (sym
->old_symbol
->as
);
2539 if (sym
->old_symbol
->value
!= sym
->value
)
2540 gfc_free_expr (sym
->old_symbol
->value
);
2542 if (sym
->old_symbol
->formal
!= sym
->formal
)
2543 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2545 gfc_free (sym
->old_symbol
);
2546 sym
->old_symbol
= NULL
;
2550 /* Makes the changes made in the current statement permanent-- gets
2551 rid of undo information. */
2554 gfc_commit_symbols (void)
2558 for (p
= changed_syms
; p
; p
= q
)
2564 free_old_symbol (p
);
2566 changed_syms
= NULL
;
2570 /* Makes the changes made in one symbol permanent -- gets rid of undo
2574 gfc_commit_symbol (gfc_symbol
*sym
)
2578 if (changed_syms
== sym
)
2579 changed_syms
= sym
->tlink
;
2582 for (p
= changed_syms
; p
; p
= p
->tlink
)
2583 if (p
->tlink
== sym
)
2585 p
->tlink
= sym
->tlink
;
2594 free_old_symbol (sym
);
2598 /* Recursive function that deletes an entire tree and all the common
2599 head structures it points to. */
2602 free_common_tree (gfc_symtree
* common_tree
)
2604 if (common_tree
== NULL
)
2607 free_common_tree (common_tree
->left
);
2608 free_common_tree (common_tree
->right
);
2610 gfc_free (common_tree
);
2614 /* Recursive function that deletes an entire tree and all the user
2615 operator nodes that it contains. */
2618 free_uop_tree (gfc_symtree
*uop_tree
)
2621 if (uop_tree
== NULL
)
2624 free_uop_tree (uop_tree
->left
);
2625 free_uop_tree (uop_tree
->right
);
2627 gfc_free_interface (uop_tree
->n
.uop
->operator);
2629 gfc_free (uop_tree
->n
.uop
);
2630 gfc_free (uop_tree
);
2634 /* Recursive function that deletes an entire tree and all the symbols
2635 that it contains. */
2638 free_sym_tree (gfc_symtree
*sym_tree
)
2643 if (sym_tree
== NULL
)
2646 free_sym_tree (sym_tree
->left
);
2647 free_sym_tree (sym_tree
->right
);
2649 sym
= sym_tree
->n
.sym
;
2653 gfc_internal_error ("free_sym_tree(): Negative refs");
2655 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2657 /* As formal_ns contains a reference to sym, delete formal_ns just
2658 before the deletion of sym. */
2659 ns
= sym
->formal_ns
;
2660 sym
->formal_ns
= NULL
;
2661 gfc_free_namespace (ns
);
2663 else if (sym
->refs
== 0)
2665 /* Go ahead and delete the symbol. */
2666 gfc_free_symbol (sym
);
2669 gfc_free (sym_tree
);
2673 /* Free the derived type list. */
2676 gfc_free_dt_list (void)
2678 gfc_dt_list
*dt
, *n
;
2680 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2686 gfc_derived_types
= NULL
;
2690 /* Free the gfc_equiv_info's. */
2693 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2697 gfc_free_equiv_infos (s
->next
);
2702 /* Free the gfc_equiv_lists. */
2705 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2709 gfc_free_equiv_lists (l
->next
);
2710 gfc_free_equiv_infos (l
->equiv
);
2715 /* Free a namespace structure and everything below it. Interface
2716 lists associated with intrinsic operators are not freed. These are
2717 taken care of when a specific name is freed. */
2720 gfc_free_namespace (gfc_namespace
*ns
)
2722 gfc_charlen
*cl
, *cl2
;
2723 gfc_namespace
*p
, *q
;
2732 gcc_assert (ns
->refs
== 0);
2734 gfc_free_statements (ns
->code
);
2736 free_sym_tree (ns
->sym_root
);
2737 free_uop_tree (ns
->uop_root
);
2738 free_common_tree (ns
->common_root
);
2740 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
2743 gfc_free_expr (cl
->length
);
2747 free_st_labels (ns
->st_labels
);
2749 gfc_free_equiv (ns
->equiv
);
2750 gfc_free_equiv_lists (ns
->equiv_lists
);
2752 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2753 gfc_free_interface (ns
->operator[i
]);
2755 gfc_free_data (ns
->data
);
2759 /* Recursively free any contained namespaces. */
2764 gfc_free_namespace (q
);
2770 gfc_symbol_init_2 (void)
2773 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
2778 gfc_symbol_done_2 (void)
2781 gfc_free_namespace (gfc_current_ns
);
2782 gfc_current_ns
= NULL
;
2783 gfc_free_dt_list ();
2787 /* Clear mark bits from symbol nodes associated with a symtree node. */
2790 clear_sym_mark (gfc_symtree
*st
)
2793 st
->n
.sym
->mark
= 0;
2797 /* Recursively traverse the symtree nodes. */
2800 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
2806 gfc_traverse_symtree (st
->left
, func
);
2807 gfc_traverse_symtree (st
->right
, func
);
2812 /* Recursive namespace traversal function. */
2815 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
2821 if (st
->n
.sym
->mark
== 0)
2822 (*func
) (st
->n
.sym
);
2823 st
->n
.sym
->mark
= 1;
2825 traverse_ns (st
->left
, func
);
2826 traverse_ns (st
->right
, func
);
2830 /* Call a given function for all symbols in the namespace. We take
2831 care that each gfc_symbol node is called exactly once. */
2834 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
2837 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
2839 traverse_ns (ns
->sym_root
, func
);
2843 /* Return TRUE if the symbol is an automatic variable. */
2846 gfc_is_var_automatic (gfc_symbol
*sym
)
2848 /* Pointer and allocatable variables are never automatic. */
2849 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2851 /* Check for arrays with non-constant size. */
2852 if (sym
->attr
.dimension
&& sym
->as
2853 && !gfc_is_compile_time_shape (sym
->as
))
2855 /* Check for non-constant length character variables. */
2856 if (sym
->ts
.type
== BT_CHARACTER
2858 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
2863 /* Given a symbol, mark it as SAVEd if it is allowed. */
2866 save_symbol (gfc_symbol
*sym
)
2869 if (sym
->attr
.use_assoc
)
2872 if (sym
->attr
.in_common
2874 || sym
->attr
.flavor
!= FL_VARIABLE
)
2876 /* Automatic objects are not saved. */
2877 if (gfc_is_var_automatic (sym
))
2879 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
2883 /* Mark those symbols which can be SAVEd as such. */
2886 gfc_save_all (gfc_namespace
*ns
)
2889 gfc_traverse_ns (ns
, save_symbol
);
2894 /* Make sure that no changes to symbols are pending. */
2897 gfc_symbol_state(void) {
2899 if (changed_syms
!= NULL
)
2900 gfc_internal_error("Symbol changes still pending!");
2905 /************** Global symbol handling ************/
2908 /* Search a tree for the global symbol. */
2911 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
2920 c
= strcmp (name
, symbol
->name
);
2924 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
2931 /* Compare two global symbols. Used for managing the BB tree. */
2934 gsym_compare (void *_s1
, void *_s2
)
2936 gfc_gsymbol
*s1
, *s2
;
2938 s1
= (gfc_gsymbol
*) _s1
;
2939 s2
= (gfc_gsymbol
*) _s2
;
2940 return strcmp (s1
->name
, s2
->name
);
2944 /* Get a global symbol, creating it if it doesn't exist. */
2947 gfc_get_gsymbol (const char *name
)
2951 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2955 s
= gfc_getmem (sizeof (gfc_gsymbol
));
2956 s
->type
= GSYM_UNKNOWN
;
2957 s
->name
= gfc_get_string (name
);
2959 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
2966 get_iso_c_binding_dt (int sym_id
)
2968 gfc_dt_list
*dt_list
;
2970 dt_list
= gfc_derived_types
;
2972 /* Loop through the derived types in the name list, searching for
2973 the desired symbol from iso_c_binding. Search the parent namespaces
2974 if necessary and requested to (parent_flag). */
2975 while (dt_list
!= NULL
)
2977 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
2978 && dt_list
->derived
->intmod_sym_id
== sym_id
)
2979 return dt_list
->derived
;
2981 dt_list
= dt_list
->next
;
2988 /* Verifies that the given derived type symbol, derived_sym, is interoperable
2989 with C. This is necessary for any derived type that is BIND(C) and for
2990 derived types that are parameters to functions that are BIND(C). All
2991 fields of the derived type are required to be interoperable, and are tested
2992 for such. If an error occurs, the errors are reported here, allowing for
2993 multiple errors to be handled for a single derived type. */
2996 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
2998 gfc_component
*curr_comp
= NULL
;
2999 try is_c_interop
= FAILURE
;
3000 try retval
= SUCCESS
;
3002 if (derived_sym
== NULL
)
3003 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3004 "unexpectedly NULL");
3006 /* If we've already looked at this derived symbol, do not look at it again
3007 so we don't repeat warnings/errors. */
3008 if (derived_sym
->ts
.is_c_interop
)
3011 /* The derived type must have the BIND attribute to be interoperable
3012 J3/04-007, Section 15.2.3. */
3013 if (derived_sym
->attr
.is_bind_c
!= 1)
3015 derived_sym
->ts
.is_c_interop
= 0;
3016 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3017 "attribute to be C interoperable", derived_sym
->name
,
3018 &(derived_sym
->declared_at
));
3022 curr_comp
= derived_sym
->components
;
3024 /* TODO: is this really an error? */
3025 if (curr_comp
== NULL
)
3027 gfc_error ("Derived type '%s' at %L is empty",
3028 derived_sym
->name
, &(derived_sym
->declared_at
));
3032 /* Initialize the derived type as being C interoperable.
3033 If we find an error in the components, this will be set false. */
3034 derived_sym
->ts
.is_c_interop
= 1;
3036 /* Loop through the list of components to verify that the kind of
3037 each is a C interoperable type. */
3040 /* The components cannot be pointers (fortran sense).
3041 J3/04-007, Section 15.2.3, C1505. */
3042 if (curr_comp
->pointer
!= 0)
3044 gfc_error ("Component '%s' at %L cannot have the "
3045 "POINTER attribute because it is a member "
3046 "of the BIND(C) derived type '%s' at %L",
3047 curr_comp
->name
, &(curr_comp
->loc
),
3048 derived_sym
->name
, &(derived_sym
->declared_at
));
3052 /* The components cannot be allocatable.
3053 J3/04-007, Section 15.2.3, C1505. */
3054 if (curr_comp
->allocatable
!= 0)
3056 gfc_error ("Component '%s' at %L cannot have the "
3057 "ALLOCATABLE attribute because it is a member "
3058 "of the BIND(C) derived type '%s' at %L",
3059 curr_comp
->name
, &(curr_comp
->loc
),
3060 derived_sym
->name
, &(derived_sym
->declared_at
));
3064 /* BIND(C) derived types must have interoperable components. */
3065 if (curr_comp
->ts
.type
== BT_DERIVED
3066 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3067 && curr_comp
->ts
.derived
!= derived_sym
)
3069 /* This should be allowed; the draft says a derived-type can not
3070 have type parameters if it is has the BIND attribute. Type
3071 parameters seem to be for making parameterized derived types.
3072 There's no need to verify the type if it is c_ptr/c_funptr. */
3073 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3077 /* Grab the typespec for the given component and test the kind. */
3078 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3081 if (is_c_interop
!= SUCCESS
)
3083 /* Report warning and continue since not fatal. The
3084 draft does specify a constraint that requires all fields
3085 to interoperate, but if the user says real(4), etc., it
3086 may interoperate with *something* in C, but the compiler
3087 most likely won't know exactly what. Further, it may not
3088 interoperate with the same data type(s) in C if the user
3089 recompiles with different flags (e.g., -m32 and -m64 on
3090 x86_64 and using integer(4) to claim interop with a
3092 if (derived_sym
->attr
.is_bind_c
== 1)
3093 /* If the derived type is bind(c), all fields must be
3095 gfc_warning ("Component '%s' in derived type '%s' at %L "
3096 "may not be C interoperable, even though "
3097 "derived type '%s' is BIND(C)",
3098 curr_comp
->name
, derived_sym
->name
,
3099 &(curr_comp
->loc
), derived_sym
->name
);
3101 /* If derived type is param to bind(c) routine, or to one
3102 of the iso_c_binding procs, it must be interoperable, so
3103 all fields must interop too. */
3104 gfc_warning ("Component '%s' in derived type '%s' at %L "
3105 "may not be C interoperable",
3106 curr_comp
->name
, derived_sym
->name
,
3111 curr_comp
= curr_comp
->next
;
3112 } while (curr_comp
!= NULL
);
3115 /* Make sure we don't have conflicts with the attributes. */
3116 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3118 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3119 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3120 &(derived_sym
->declared_at
));
3124 if (derived_sym
->attr
.sequence
!= 0)
3126 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3127 "attribute because it is BIND(C)", derived_sym
->name
,
3128 &(derived_sym
->declared_at
));
3132 /* Mark the derived type as not being C interoperable if we found an
3133 error. If there were only warnings, proceed with the assumption
3134 it's interoperable. */
3135 if (retval
== FAILURE
)
3136 derived_sym
->ts
.is_c_interop
= 0;
3142 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3145 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3146 const char *module_name
)
3148 gfc_symtree
*tmp_symtree
;
3149 gfc_symbol
*tmp_sym
;
3151 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3153 if (tmp_symtree
!= NULL
)
3154 tmp_sym
= tmp_symtree
->n
.sym
;
3158 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3159 "create symbol for %s", ptr_name
);
3162 /* Set up the symbol's important fields. Save attr required so we can
3163 initialize the ptr to NULL. */
3164 tmp_sym
->attr
.save
= 1;
3165 tmp_sym
->ts
.is_c_interop
= 1;
3166 tmp_sym
->attr
.is_c_interop
= 1;
3167 tmp_sym
->ts
.is_iso_c
= 1;
3168 tmp_sym
->ts
.type
= BT_DERIVED
;
3170 /* The c_ptr and c_funptr derived types will provide the
3171 definition for c_null_ptr and c_null_funptr, respectively. */
3172 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3173 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3175 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3176 if (tmp_sym
->ts
.derived
== NULL
)
3178 /* This can occur if the user forgot to declare c_ptr or
3179 c_funptr and they're trying to use one of the procedures
3180 that has arg(s) of the missing type. In this case, a
3181 regular version of the thing should have been put in the
3183 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3184 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3185 (char *) (ptr_id
== ISOCBINDING_NULL_PTR
3186 ? "_gfortran_iso_c_binding_c_ptr"
3187 : "_gfortran_iso_c_binding_c_funptr"));
3189 tmp_sym
->ts
.derived
=
3190 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3191 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3194 /* Module name is some mangled version of iso_c_binding. */
3195 tmp_sym
->module
= gfc_get_string (module_name
);
3197 /* Say it's from the iso_c_binding module. */
3198 tmp_sym
->attr
.is_iso_c
= 1;
3200 tmp_sym
->attr
.use_assoc
= 1;
3201 tmp_sym
->attr
.is_bind_c
= 1;
3202 /* Set the binding_label. */
3203 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3205 /* Set the c_address field of c_null_ptr and c_null_funptr to
3206 the value of NULL. */
3207 tmp_sym
->value
= gfc_get_expr ();
3208 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3209 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3210 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3211 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3212 /* This line will initialize the c_null_ptr/c_null_funptr
3213 c_address field to NULL. */
3214 tmp_sym
->value
->value
.constructor
->expr
= gfc_int_expr (0);
3215 /* Must declare c_null_ptr and c_null_funptr as having the
3216 PARAMETER attribute so they can be used in init expressions. */
3217 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3223 /* Add a formal argument, gfc_formal_arglist, to the
3224 end of the given list of arguments. Set the reference to the
3225 provided symbol, param_sym, in the argument. */
3228 add_formal_arg (gfc_formal_arglist
**head
,
3229 gfc_formal_arglist
**tail
,
3230 gfc_formal_arglist
*formal_arg
,
3231 gfc_symbol
*param_sym
)
3233 /* Put in list, either as first arg or at the tail (curr arg). */
3235 *head
= *tail
= formal_arg
;
3238 (*tail
)->next
= formal_arg
;
3239 (*tail
) = formal_arg
;
3242 (*tail
)->sym
= param_sym
;
3243 (*tail
)->next
= NULL
;
3249 /* Generates a symbol representing the CPTR argument to an
3250 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3251 CPTR and add it to the provided argument list. */
3254 gen_cptr_param (gfc_formal_arglist
**head
,
3255 gfc_formal_arglist
**tail
,
3256 const char *module_name
,
3257 gfc_namespace
*ns
, const char *c_ptr_name
)
3259 gfc_symbol
*param_sym
= NULL
;
3260 gfc_symbol
*c_ptr_sym
= NULL
;
3261 gfc_symtree
*param_symtree
= NULL
;
3262 gfc_formal_arglist
*formal_arg
= NULL
;
3263 const char *c_ptr_in
;
3264 const char *c_ptr_type
= "c_ptr";
3266 if(c_ptr_name
== NULL
)
3267 c_ptr_in
= "gfc_cptr__";
3269 c_ptr_in
= c_ptr_name
;
3270 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3271 if (param_symtree
!= NULL
)
3272 param_sym
= param_symtree
->n
.sym
;
3274 gfc_internal_error ("gen_cptr_param(): Unable to "
3275 "create symbol for %s", c_ptr_in
);
3277 /* Set up the appropriate fields for the new c_ptr param sym. */
3279 param_sym
->attr
.flavor
= FL_DERIVED
;
3280 param_sym
->ts
.type
= BT_DERIVED
;
3281 param_sym
->attr
.intent
= INTENT_IN
;
3282 param_sym
->attr
.dummy
= 1;
3284 /* This will pass the ptr to the iso_c routines as a (void *). */
3285 param_sym
->attr
.value
= 1;
3286 param_sym
->attr
.use_assoc
= 1;
3288 /* Get the symbol for c_ptr, no matter what it's name is (user renamed). */
3289 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3290 if (c_ptr_sym
== NULL
)
3292 /* This can happen if the user did not define c_ptr but they are
3293 trying to use one of the iso_c_binding functions that need it. */
3294 gfc_error_now ("Type 'C_PTR' required for ISO_C_BINDING function at %C");
3295 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3296 (char *) "_gfortran_iso_c_binding_c_ptr");
3298 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3301 param_sym
->ts
.derived
= c_ptr_sym
;
3302 param_sym
->module
= gfc_get_string (module_name
);
3304 /* Make new formal arg. */
3305 formal_arg
= gfc_get_formal_arglist ();
3306 /* Add arg to list of formal args (the CPTR arg). */
3307 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3311 /* Generates a symbol representing the FPTR argument to an
3312 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3313 FPTR and add it to the provided argument list. */
3316 gen_fptr_param (gfc_formal_arglist
**head
,
3317 gfc_formal_arglist
**tail
,
3318 const char *module_name
,
3319 gfc_namespace
*ns
, const char *f_ptr_name
)
3321 gfc_symbol
*param_sym
= NULL
;
3322 gfc_symtree
*param_symtree
= NULL
;
3323 gfc_formal_arglist
*formal_arg
= NULL
;
3324 const char *f_ptr_out
= "gfc_fptr__";
3326 if (f_ptr_name
!= NULL
)
3327 f_ptr_out
= f_ptr_name
;
3329 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3330 if (param_symtree
!= NULL
)
3331 param_sym
= param_symtree
->n
.sym
;
3333 gfc_internal_error ("generateFPtrParam(): Unable to "
3334 "create symbol for %s", f_ptr_out
);
3336 /* Set up the necessary fields for the fptr output param sym. */
3338 param_sym
->attr
.pointer
= 1;
3339 param_sym
->attr
.dummy
= 1;
3340 param_sym
->attr
.use_assoc
= 1;
3342 /* ISO C Binding type to allow any pointer type as actual param. */
3343 param_sym
->ts
.type
= BT_VOID
;
3344 param_sym
->module
= gfc_get_string (module_name
);
3347 formal_arg
= gfc_get_formal_arglist ();
3348 /* Add arg to list of formal args. */
3349 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3353 /* Generates a symbol representing the optional SHAPE argument for the
3354 iso_c_binding c_f_pointer() procedure. Also, create a
3355 gfc_formal_arglist for the SHAPE and add it to the provided
3359 gen_shape_param (gfc_formal_arglist
**head
,
3360 gfc_formal_arglist
**tail
,
3361 const char *module_name
,
3362 gfc_namespace
*ns
, const char *shape_param_name
)
3364 gfc_symbol
*param_sym
= NULL
;
3365 gfc_symtree
*param_symtree
= NULL
;
3366 gfc_formal_arglist
*formal_arg
= NULL
;
3367 const char *shape_param
= "gfc_shape_array__";
3370 if (shape_param_name
!= NULL
)
3371 shape_param
= shape_param_name
;
3373 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3374 if (param_symtree
!= NULL
)
3375 param_sym
= param_symtree
->n
.sym
;
3377 gfc_internal_error ("generateShapeParam(): Unable to "
3378 "create symbol for %s", shape_param
);
3380 /* Set up the necessary fields for the shape input param sym. */
3382 param_sym
->attr
.dummy
= 1;
3383 param_sym
->attr
.use_assoc
= 1;
3385 /* Integer array, rank 1, describing the shape of the object. */
3386 param_sym
->ts
.type
= BT_INTEGER
;
3387 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3388 param_sym
->as
= gfc_get_array_spec ();
3390 /* Clear out the dimension info for the array. */
3391 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3393 param_sym
->as
->lower
[i
] = NULL
;
3394 param_sym
->as
->upper
[i
] = NULL
;
3396 param_sym
->as
->rank
= 1;
3397 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3399 /* The extent is unknown until we get it. The length give us
3400 the rank the incoming pointer. */
3401 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3403 /* The arg is also optional; it is required iff the second arg
3404 (fptr) is to an array, otherwise, it's ignored. */
3405 param_sym
->attr
.optional
= 1;
3406 param_sym
->attr
.intent
= INTENT_IN
;
3407 param_sym
->attr
.dimension
= 1;
3408 param_sym
->module
= gfc_get_string (module_name
);
3411 formal_arg
= gfc_get_formal_arglist ();
3412 /* Add arg to list of formal args. */
3413 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3416 /* Add a procedure interface to the given symbol (i.e., store a
3417 reference to the list of formal arguments). */
3420 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3421 gfc_formal_arglist
*formal
)
3424 sym
->formal
= formal
;
3425 sym
->attr
.if_source
= source
;
3429 /* Builds the parameter list for the iso_c_binding procedure
3430 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3431 generic version of either the c_f_pointer or c_f_procpointer
3432 functions. The new_proc_sym represents a "resolved" version of the
3433 symbol. The functions are resolved to match the types of their
3434 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3435 something similar to c_f_pointer_i4 if the type of data object fptr
3436 pointed to was a default integer. The actual name of the resolved
3437 procedure symbol is further mangled with the module name, etc., but
3438 the idea holds true. */
3441 build_formal_args (gfc_symbol
*new_proc_sym
,
3442 gfc_symbol
*old_sym
, int add_optional_arg
)
3444 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3445 gfc_namespace
*parent_ns
= NULL
;
3447 parent_ns
= gfc_current_ns
;
3448 /* Create a new namespace, which will be the formal ns (namespace
3449 of the formal args). */
3450 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3451 gfc_current_ns
->proc_name
= new_proc_sym
;
3453 /* Generate the params. */
3454 if ((old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3455 (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3457 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3458 gfc_current_ns
, "cptr");
3459 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3460 gfc_current_ns
, "fptr");
3462 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3463 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3465 gen_shape_param (&head
, &tail
,
3466 (const char *) new_proc_sym
->module
,
3467 gfc_current_ns
, "shape");
3470 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3472 /* c_associated has one required arg and one optional; both
3474 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3475 gfc_current_ns
, "c_ptr_1");
3476 if (add_optional_arg
)
3478 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3479 gfc_current_ns
, "c_ptr_2");
3480 /* The last param is optional so mark it as such. */
3481 tail
->sym
->attr
.optional
= 1;
3485 /* Add the interface (store formal args to new_proc_sym). */
3486 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3488 /* Set up the formal_ns pointer to the one created for the
3489 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3490 new_proc_sym
->formal_ns
= gfc_current_ns
;
3492 gfc_current_ns
= parent_ns
;
3496 /* Generate the given set of C interoperable kind objects, or all
3497 interoperable kinds. This function will only be given kind objects
3498 for valid iso_c_binding defined types because this is verified when
3499 the 'use' statement is parsed. If the user gives an 'only' clause,
3500 the specific kinds are looked up; if they don't exist, an error is
3501 reported. If the user does not give an 'only' clause, all
3502 iso_c_binding symbols are generated. If a list of specific kinds
3503 is given, it must have a NULL in the first empty spot to mark the
3508 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3511 char *name
= (local_name
&& local_name
[0]) ? local_name
3512 : c_interop_kinds_table
[s
].name
;
3513 gfc_symtree
*tmp_symtree
= NULL
;
3514 gfc_symbol
*tmp_sym
= NULL
;
3515 gfc_dt_list
**dt_list_ptr
= NULL
;
3516 gfc_component
*tmp_comp
= NULL
;
3517 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3520 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3522 /* Already exists in this scope so don't re-add it.
3523 TODO: we should probably check that it's really the same symbol. */
3524 if (tmp_symtree
!= NULL
)
3527 /* Create the sym tree in the current ns. */
3528 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3530 tmp_sym
= tmp_symtree
->n
.sym
;
3532 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3535 /* Say what module this symbol belongs to. */
3536 tmp_sym
->module
= gfc_get_string (mod_name
);
3537 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3538 tmp_sym
->intmod_sym_id
= s
;
3543 #define NAMED_INTCST(a,b,c) case a :
3544 #define NAMED_REALCST(a,b,c) case a :
3545 #define NAMED_CMPXCST(a,b,c) case a :
3546 #define NAMED_LOGCST(a,b,c) case a :
3547 #define NAMED_CHARKNDCST(a,b,c) case a :
3548 #include "iso-c-binding.def"
3550 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3552 /* Initialize an integer constant expression node. */
3553 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3554 tmp_sym
->ts
.type
= BT_INTEGER
;
3555 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3557 /* Mark this type as a C interoperable one. */
3558 tmp_sym
->ts
.is_c_interop
= 1;
3559 tmp_sym
->ts
.is_iso_c
= 1;
3560 tmp_sym
->value
->ts
.is_c_interop
= 1;
3561 tmp_sym
->value
->ts
.is_iso_c
= 1;
3562 tmp_sym
->attr
.is_c_interop
= 1;
3564 /* Tell what f90 type this c interop kind is valid. */
3565 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3567 /* Say it's from the iso_c_binding module. */
3568 tmp_sym
->attr
.is_iso_c
= 1;
3570 /* Make it use associated. */
3571 tmp_sym
->attr
.use_assoc
= 1;
3575 #define NAMED_CHARCST(a,b,c) case a :
3576 #include "iso-c-binding.def"
3578 /* Initialize an integer constant expression node for the
3579 length of the character. */
3580 tmp_sym
->value
= gfc_get_expr ();
3581 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3582 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3583 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3584 tmp_sym
->value
->where
= gfc_current_locus
;
3585 tmp_sym
->value
->ts
.is_c_interop
= 1;
3586 tmp_sym
->value
->ts
.is_iso_c
= 1;
3587 tmp_sym
->value
->value
.character
.length
= 1;
3588 tmp_sym
->value
->value
.character
.string
= gfc_getmem (2);
3589 tmp_sym
->value
->value
.character
.string
[0]
3590 = (char) c_interop_kinds_table
[s
].value
;
3591 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3593 /* May not need this in both attr and ts, but do need in
3594 attr for writing module file. */
3595 tmp_sym
->attr
.is_c_interop
= 1;
3597 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3598 tmp_sym
->ts
.type
= BT_CHARACTER
;
3600 /* Need to set it to the C_CHAR kind. */
3601 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3603 /* Mark this type as a C interoperable one. */
3604 tmp_sym
->ts
.is_c_interop
= 1;
3605 tmp_sym
->ts
.is_iso_c
= 1;
3607 /* Tell what f90 type this c interop kind is valid. */
3608 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
3610 /* Say it's from the iso_c_binding module. */
3611 tmp_sym
->attr
.is_iso_c
= 1;
3613 /* Make it use associated. */
3614 tmp_sym
->attr
.use_assoc
= 1;
3617 case ISOCBINDING_PTR
:
3618 case ISOCBINDING_FUNPTR
:
3620 /* Initialize an integer constant expression node. */
3621 tmp_sym
->attr
.flavor
= FL_DERIVED
;
3622 tmp_sym
->ts
.is_c_interop
= 1;
3623 tmp_sym
->attr
.is_c_interop
= 1;
3624 tmp_sym
->attr
.is_iso_c
= 1;
3625 tmp_sym
->ts
.is_iso_c
= 1;
3626 tmp_sym
->ts
.type
= BT_DERIVED
;
3628 /* A derived type must have the bind attribute to be
3629 interoperable (J3/04-007, Section 15.2.3), even though
3630 the binding label is not used. */
3631 tmp_sym
->attr
.is_bind_c
= 1;
3633 tmp_sym
->attr
.referenced
= 1;
3635 tmp_sym
->ts
.derived
= tmp_sym
;
3637 /* Add the symbol created for the derived type to the current ns. */
3638 dt_list_ptr
= &(gfc_derived_types
);
3639 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
3640 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3642 /* There is already at least one derived type in the list, so append
3643 the one we're currently building for c_ptr or c_funptr. */
3644 if (*dt_list_ptr
!= NULL
)
3645 dt_list_ptr
= &((*dt_list_ptr
)->next
);
3646 (*dt_list_ptr
) = gfc_get_dt_list ();
3647 (*dt_list_ptr
)->derived
= tmp_sym
;
3648 (*dt_list_ptr
)->next
= NULL
;
3650 /* Set up the component of the derived type, which will be
3651 an integer with kind equal to c_ptr_size. Mangle the name of
3652 the field for the c_address to prevent the curious user from
3653 trying to access it from Fortran. */
3654 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
3655 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
3656 if (tmp_comp
== NULL
)
3657 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3658 "create component for c_address");
3660 tmp_comp
->ts
.type
= BT_INTEGER
;
3662 /* Set this because the module will need to read/write this field. */
3663 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
3665 /* The kinds for c_ptr and c_funptr are the same. */
3666 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
3667 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
3669 tmp_comp
->pointer
= 0;
3670 tmp_comp
->dimension
= 0;
3672 /* Mark the component as C interoperable. */
3673 tmp_comp
->ts
.is_c_interop
= 1;
3675 /* Make it use associated (iso_c_binding module). */
3676 tmp_sym
->attr
.use_assoc
= 1;
3679 case ISOCBINDING_NULL_PTR
:
3680 case ISOCBINDING_NULL_FUNPTR
:
3681 gen_special_c_interop_ptr (s
, name
, mod_name
);
3684 case ISOCBINDING_F_POINTER
:
3685 case ISOCBINDING_ASSOCIATED
:
3686 case ISOCBINDING_LOC
:
3687 case ISOCBINDING_FUNLOC
:
3688 case ISOCBINDING_F_PROCPOINTER
:
3690 tmp_sym
->attr
.proc
= PROC_MODULE
;
3692 /* Use the procedure's name as it is in the iso_c_binding module for
3693 setting the binding label in case the user renamed the symbol. */
3694 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
3695 c_interop_kinds_table
[s
].name
);
3696 tmp_sym
->attr
.is_iso_c
= 1;
3697 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
3698 tmp_sym
->attr
.subroutine
= 1;
3701 /* TODO! This needs to be finished more for the expr of the
3702 function or something!
3703 This may not need to be here, because trying to do c_loc
3705 if (s
== ISOCBINDING_ASSOCIATED
)
3707 tmp_sym
->attr
.function
= 1;
3708 tmp_sym
->ts
.type
= BT_LOGICAL
;
3709 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
3710 tmp_sym
->result
= tmp_sym
;
3714 /* Here, we're taking the simple approach. We're defining
3715 c_loc as an external identifier so the compiler will put
3716 what we expect on the stack for the address we want the
3718 tmp_sym
->ts
.type
= BT_DERIVED
;
3719 if (s
== ISOCBINDING_LOC
)
3720 tmp_sym
->ts
.derived
=
3721 get_iso_c_binding_dt (ISOCBINDING_PTR
);
3723 tmp_sym
->ts
.derived
=
3724 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3726 if (tmp_sym
->ts
.derived
== NULL
)
3728 /* Create the necessary derived type so we can continue
3729 processing the file. */
3730 generate_isocbinding_symbol
3731 (mod_name
, s
== ISOCBINDING_FUNLOC
3732 ? ISOCBINDING_FUNPTR
: ISOCBINDING_FUNPTR
,
3733 (char *)(s
== ISOCBINDING_FUNLOC
3734 ? "_gfortran_iso_c_binding_c_funptr"
3735 : "_gfortran_iso_c_binding_c_ptr"));
3736 tmp_sym
->ts
.derived
=
3737 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
3738 ? ISOCBINDING_FUNPTR
3742 /* The function result is itself (no result clause). */
3743 tmp_sym
->result
= tmp_sym
;
3744 tmp_sym
->attr
.external
= 1;
3745 tmp_sym
->attr
.use_assoc
= 0;
3746 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
3747 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
3751 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
3752 tmp_sym
->attr
.contained
= 0;
3754 /* Try using this builder routine, with the new and old symbols
3755 both being the generic iso_c proc sym being created. This
3756 will create the formal args (and the new namespace for them).
3757 Don't build an arg list for c_loc because we're going to treat
3758 c_loc as an external procedure. */
3759 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
3760 /* The 1 says to add any optional args, if applicable. */
3761 build_formal_args (tmp_sym
, tmp_sym
, 1);
3763 /* Set this after setting up the symbol, to prevent error messages. */
3764 tmp_sym
->attr
.use_assoc
= 1;
3766 /* This symbol will not be referenced directly. It will be
3767 resolved to the implementation for the given f90 kind. */
3768 tmp_sym
->attr
.referenced
= 0;
3778 /* Creates a new symbol based off of an old iso_c symbol, with a new
3779 binding label. This function can be used to create a new,
3780 resolved, version of a procedure symbol for c_f_pointer or
3781 c_f_procpointer that is based on the generic symbols. A new
3782 parameter list is created for the new symbol using
3783 build_formal_args(). The add_optional_flag specifies whether the
3784 to add the optional SHAPE argument. The new symbol is
3788 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
3789 char *new_binding_label
, int add_optional_arg
)
3791 gfc_symtree
*new_symtree
= NULL
;
3793 /* See if we have a symbol by that name already available, looking
3794 through any parent namespaces. */
3795 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
3796 if (new_symtree
!= NULL
)
3797 /* Return the existing symbol. */
3798 return new_symtree
->n
.sym
;
3800 /* Create the symtree/symbol, with attempted host association. */
3801 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
3802 if (new_symtree
== NULL
)
3803 gfc_internal_error ("get_iso_c_sym(): Unable to create "
3804 "symtree for '%s'", new_name
);
3806 /* Now fill in the fields of the resolved symbol with the old sym. */
3807 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
3808 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
3809 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
3810 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
3811 /* Build the formal arg list. */
3812 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
3814 gfc_commit_symbol (new_symtree
->n
.sym
);
3816 return new_symtree
->n
.sym
;