1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors
[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
38 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
39 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
40 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 const mstring procedures
[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
47 minit ("MODULE-PROC", PROC_MODULE
),
48 minit ("INTERNAL-PROC", PROC_INTERNAL
),
49 minit ("DUMMY-PROC", PROC_DUMMY
),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
56 const mstring intents
[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
59 minit ("IN", INTENT_IN
),
60 minit ("OUT", INTENT_OUT
),
61 minit ("INOUT", INTENT_INOUT
),
65 const mstring access_types
[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
68 minit ("PUBLIC", ACCESS_PUBLIC
),
69 minit ("PRIVATE", ACCESS_PRIVATE
),
73 const mstring ifsrc_types
[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN
),
76 minit ("DECL", IFSRC_DECL
),
77 minit ("BODY", IFSRC_IFBODY
),
78 minit ("USAGE", IFSRC_USAGE
)
81 const mstring save_status
[] =
83 minit ("UNKNOWN", SAVE_NONE
),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order
= 1;
94 gfc_namespace
*gfc_current_ns
;
96 gfc_gsymbol
*gfc_gsym_root
= NULL
;
98 static gfc_symbol
*changed_syms
= NULL
;
100 gfc_dt_list
*gfc_derived_types
;
103 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
105 /* The following static variable indicates whether a particular element has
106 been explicitly set or not. */
108 static int new_flag
[GFC_LETTERS
];
111 /* Handle a correctly parsed IMPLICIT NONE. */
114 gfc_set_implicit_none (void)
118 if (gfc_current_ns
->seen_implicit_none
)
120 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
124 gfc_current_ns
->seen_implicit_none
= 1;
126 for (i
= 0; i
< GFC_LETTERS
; i
++)
128 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
129 gfc_current_ns
->set_flag
[i
] = 1;
134 /* Reset the implicit range flags. */
137 gfc_clear_new_implicit (void)
141 for (i
= 0; i
< GFC_LETTERS
; i
++)
146 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
149 gfc_add_new_implicit_range (int c1
, int c2
)
156 for (i
= c1
; i
<= c2
; i
++)
160 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
172 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
173 the new implicit types back into the existing types will work. */
176 gfc_merge_new_implicit (gfc_typespec
*ts
)
180 if (gfc_current_ns
->seen_implicit_none
)
182 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
186 for (i
= 0; i
< GFC_LETTERS
; i
++)
191 if (gfc_current_ns
->set_flag
[i
])
193 gfc_error ("Letter %c already has an IMPLICIT type at %C",
197 gfc_current_ns
->default_type
[i
] = *ts
;
198 gfc_current_ns
->set_flag
[i
] = 1;
205 /* Given a symbol, return a pointer to the typespec for its default type. */
208 gfc_get_default_type (gfc_symbol
*sym
, gfc_namespace
*ns
)
212 letter
= sym
->name
[0];
214 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
215 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
216 "gfortran developers, and should not be used for "
217 "implicitly typed variables");
219 if (letter
< 'a' || letter
> 'z')
220 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
225 return &ns
->default_type
[letter
- 'a'];
229 /* Given a pointer to a symbol, set its type according to the first
230 letter of its name. Fails if the letter in question has no default
234 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
238 if (sym
->ts
.type
!= BT_UNKNOWN
)
239 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
241 ts
= gfc_get_default_type (sym
, ns
);
243 if (ts
->type
== BT_UNKNOWN
)
245 if (error_flag
&& !sym
->attr
.untyped
)
247 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
248 sym
->name
, &sym
->declared_at
);
249 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
256 sym
->attr
.implicit_type
= 1;
258 if (sym
->attr
.is_bind_c
== 1)
260 /* BIND(C) variables should not be implicitly declared. */
261 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
262 "not be C interoperable", sym
->name
, &sym
->declared_at
);
263 sym
->ts
.f90_type
= sym
->ts
.type
;
266 if (sym
->attr
.dummy
!= 0)
268 if (sym
->ns
->proc_name
!= NULL
269 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
270 || sym
->ns
->proc_name
->attr
.function
!= 0)
271 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
273 /* Dummy args to a BIND(C) routine may not be interoperable if
274 they are implicitly typed. */
275 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
276 "be C interoperable but it is a dummy argument to "
277 "the BIND(C) procedure '%s' at %L", sym
->name
,
278 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
279 &(sym
->ns
->proc_name
->declared_at
));
280 sym
->ts
.f90_type
= sym
->ts
.type
;
288 /* This function is called from parse.c(parse_progunit) to check the
289 type of the function is not implicitly typed in the host namespace
290 and to implicitly type the function result, if necessary. */
293 gfc_check_function_type (gfc_namespace
*ns
)
295 gfc_symbol
*proc
= ns
->proc_name
;
297 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
300 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
302 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
305 if (proc
->result
!= proc
)
307 proc
->ts
= proc
->result
->ts
;
308 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
309 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
310 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
311 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
316 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
317 proc
->result
->name
, &proc
->result
->declared_at
);
318 proc
->result
->attr
.untyped
= 1;
324 /******************** Symbol attribute stuff *********************/
326 /* This is a generic conflict-checker. We do this to avoid having a
327 single conflict in two places. */
329 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
330 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
331 #define conf_std(a, b, std) if (attr->a && attr->b)\
340 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
342 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
343 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
344 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
345 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
346 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
347 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
348 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
349 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
350 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
351 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
352 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
353 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
354 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
355 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE";
356 static const char *threadprivate
= "THREADPRIVATE";
362 where
= &gfc_current_locus
;
364 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
368 standard
= GFC_STD_F2003
;
372 /* Check for attributes not allowed in a BLOCK DATA. */
373 if (gfc_current_state () == COMP_BLOCK_DATA
)
377 if (attr
->in_namelist
)
379 if (attr
->allocatable
)
385 if (attr
->access
== ACCESS_PRIVATE
)
387 if (attr
->access
== ACCESS_PUBLIC
)
389 if (attr
->intent
!= INTENT_UNKNOWN
)
395 ("%s attribute not allowed in BLOCK DATA program unit at %L",
401 if (attr
->save
== SAVE_EXPLICIT
)
404 conf (in_common
, save
);
407 switch (attr
->flavor
)
415 a1
= gfc_code2string (flavors
, attr
->flavor
);
420 if (attr
->proc_pointer
)
422 a1
= gfc_code2string (flavors
, attr
->flavor
);
434 conf (dummy
, intrinsic
);
435 conf (dummy
, threadprivate
);
436 conf (pointer
, target
);
437 conf (pointer
, intrinsic
);
438 conf (pointer
, elemental
);
439 conf (allocatable
, elemental
);
441 conf (target
, external
);
442 conf (target
, intrinsic
);
444 if (!attr
->if_source
)
445 conf (external
, dimension
); /* See Fortran 95's R504. */
447 conf (external
, intrinsic
);
448 conf (entry
, intrinsic
);
450 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
452 conf (external
, subroutine
);
453 conf (external
, function
);
456 conf (allocatable
, pointer
);
457 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
458 conf_std (allocatable
, function
, GFC_STD_F2003
);
459 conf_std (allocatable
, result
, GFC_STD_F2003
);
460 conf (elemental
, recursive
);
462 conf (in_common
, dummy
);
463 conf (in_common
, allocatable
);
464 conf (in_common
, result
);
466 conf (dummy
, result
);
468 conf (in_equivalence
, use_assoc
);
469 conf (in_equivalence
, dummy
);
470 conf (in_equivalence
, target
);
471 conf (in_equivalence
, pointer
);
472 conf (in_equivalence
, function
);
473 conf (in_equivalence
, result
);
474 conf (in_equivalence
, entry
);
475 conf (in_equivalence
, allocatable
);
476 conf (in_equivalence
, threadprivate
);
478 conf (in_namelist
, pointer
);
479 conf (in_namelist
, allocatable
);
481 conf (entry
, result
);
483 conf (function
, subroutine
);
485 if (!function
&& !subroutine
)
486 conf (is_bind_c
, dummy
);
488 conf (is_bind_c
, cray_pointer
);
489 conf (is_bind_c
, cray_pointee
);
490 conf (is_bind_c
, allocatable
);
491 conf (is_bind_c
, elemental
);
493 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
494 Parameter conflict caught below. Also, value cannot be specified
495 for a dummy procedure. */
497 /* Cray pointer/pointee conflicts. */
498 conf (cray_pointer
, cray_pointee
);
499 conf (cray_pointer
, dimension
);
500 conf (cray_pointer
, pointer
);
501 conf (cray_pointer
, target
);
502 conf (cray_pointer
, allocatable
);
503 conf (cray_pointer
, external
);
504 conf (cray_pointer
, intrinsic
);
505 conf (cray_pointer
, in_namelist
);
506 conf (cray_pointer
, function
);
507 conf (cray_pointer
, subroutine
);
508 conf (cray_pointer
, entry
);
510 conf (cray_pointee
, allocatable
);
511 conf (cray_pointee
, intent
);
512 conf (cray_pointee
, optional
);
513 conf (cray_pointee
, dummy
);
514 conf (cray_pointee
, target
);
515 conf (cray_pointee
, intrinsic
);
516 conf (cray_pointee
, pointer
);
517 conf (cray_pointee
, entry
);
518 conf (cray_pointee
, in_common
);
519 conf (cray_pointee
, in_equivalence
);
520 conf (cray_pointee
, threadprivate
);
523 conf (data
, function
);
525 conf (data
, allocatable
);
526 conf (data
, use_assoc
);
528 conf (value
, pointer
)
529 conf (value
, allocatable
)
530 conf (value
, subroutine
)
531 conf (value
, function
)
532 conf (value
, volatile_
)
533 conf (value
, dimension
)
534 conf (value
, external
)
537 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
540 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
544 conf (is_protected
, intrinsic
)
545 conf (is_protected
, external
)
546 conf (is_protected
, in_common
)
548 conf (volatile_
, intrinsic
)
549 conf (volatile_
, external
)
551 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
558 conf (procedure
, allocatable
)
559 conf (procedure
, dimension
)
560 conf (procedure
, intrinsic
)
561 conf (procedure
, is_protected
)
562 conf (procedure
, target
)
563 conf (procedure
, value
)
564 conf (procedure
, volatile_
)
565 conf (procedure
, entry
)
567 a1
= gfc_code2string (flavors
, attr
->flavor
);
569 if (attr
->in_namelist
570 && attr
->flavor
!= FL_VARIABLE
571 && attr
->flavor
!= FL_PROCEDURE
572 && attr
->flavor
!= FL_UNKNOWN
)
578 switch (attr
->flavor
)
588 conf2 (is_protected
);
598 conf2 (threadprivate
);
600 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
602 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
603 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
610 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
621 if (!attr
->proc_pointer
)
624 if (attr
->subroutine
)
632 conf2 (threadprivate
);
637 case PROC_ST_FUNCTION
:
649 conf2 (threadprivate
);
669 conf2 (threadprivate
);
671 if (attr
->intent
!= INTENT_UNKNOWN
)
687 conf2 (is_protected
);
693 conf2 (threadprivate
);
706 gfc_error ("%s attribute conflicts with %s attribute at %L",
709 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
710 a1
, a2
, name
, where
);
717 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
718 "with %s attribute at %L", a1
, a2
,
723 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
724 "with %s attribute in '%s' at %L",
725 a1
, a2
, name
, where
);
734 /* Mark a symbol as referenced. */
737 gfc_set_sym_referenced (gfc_symbol
*sym
)
740 if (sym
->attr
.referenced
)
743 sym
->attr
.referenced
= 1;
745 /* Remember which order dummy variables are accessed in. */
747 sym
->dummy_order
= next_dummy_order
++;
751 /* Common subroutine called by attribute changing subroutines in order
752 to prevent them from changing a symbol that has been
753 use-associated. Returns zero if it is OK to change the symbol,
757 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
760 if (attr
->use_assoc
== 0)
764 where
= &gfc_current_locus
;
767 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
770 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
777 /* Generate an error because of a duplicate attribute. */
780 duplicate_attr (const char *attr
, locus
*where
)
784 where
= &gfc_current_locus
;
786 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
790 /* Called from decl.c (attr_decl1) to check attributes, when declared
794 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
797 if (check_used (attr
, NULL
, where
))
800 return check_conflict (attr
, NULL
, where
);
804 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
807 if (check_used (attr
, NULL
, where
))
810 if (attr
->allocatable
)
812 duplicate_attr ("ALLOCATABLE", where
);
816 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
817 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
819 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
824 attr
->allocatable
= 1;
825 return check_conflict (attr
, NULL
, where
);
830 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
833 if (check_used (attr
, name
, where
))
838 duplicate_attr ("DIMENSION", where
);
842 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
843 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
845 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
846 "at %L", name
, where
);
851 return check_conflict (attr
, name
, where
);
856 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
859 if (check_used (attr
, NULL
, where
))
864 duplicate_attr ("EXTERNAL", where
);
868 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
871 attr
->proc_pointer
= 1;
876 return check_conflict (attr
, NULL
, where
);
881 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
884 if (check_used (attr
, NULL
, where
))
889 duplicate_attr ("INTRINSIC", where
);
895 return check_conflict (attr
, NULL
, where
);
900 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
903 if (check_used (attr
, NULL
, where
))
908 duplicate_attr ("OPTIONAL", where
);
913 return check_conflict (attr
, NULL
, where
);
918 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
921 if (check_used (attr
, NULL
, where
))
924 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
925 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
927 duplicate_attr ("POINTER", where
);
931 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
932 || (attr
->if_source
== IFSRC_IFBODY
933 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
934 attr
->proc_pointer
= 1;
938 return check_conflict (attr
, NULL
, where
);
943 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
946 if (check_used (attr
, NULL
, where
))
949 attr
->cray_pointer
= 1;
950 return check_conflict (attr
, NULL
, where
);
955 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
958 if (check_used (attr
, NULL
, where
))
961 if (attr
->cray_pointee
)
963 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
964 " statements", where
);
968 attr
->cray_pointee
= 1;
969 return check_conflict (attr
, NULL
, where
);
974 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
976 if (check_used (attr
, name
, where
))
979 if (attr
->is_protected
)
981 if (gfc_notify_std (GFC_STD_LEGACY
,
982 "Duplicate PROTECTED attribute specified at %L",
988 attr
->is_protected
= 1;
989 return check_conflict (attr
, name
, where
);
994 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
997 if (check_used (attr
, name
, where
))
1001 return check_conflict (attr
, name
, where
);
1006 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
1009 if (check_used (attr
, name
, where
))
1012 if (gfc_pure (NULL
))
1015 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1020 if (attr
->save
== SAVE_EXPLICIT
)
1022 if (gfc_notify_std (GFC_STD_LEGACY
,
1023 "Duplicate SAVE attribute specified at %L",
1029 attr
->save
= SAVE_EXPLICIT
;
1030 return check_conflict (attr
, name
, where
);
1035 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1038 if (check_used (attr
, name
, where
))
1043 if (gfc_notify_std (GFC_STD_LEGACY
,
1044 "Duplicate VALUE attribute specified at %L",
1051 return check_conflict (attr
, name
, where
);
1056 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1058 /* No check_used needed as 11.2.1 of the F2003 standard allows
1059 that the local identifier made accessible by a use statement can be
1060 given a VOLATILE attribute. */
1062 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1063 if (gfc_notify_std (GFC_STD_LEGACY
,
1064 "Duplicate VOLATILE attribute specified at %L", where
)
1068 attr
->volatile_
= 1;
1069 attr
->volatile_ns
= gfc_current_ns
;
1070 return check_conflict (attr
, name
, where
);
1075 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1078 if (check_used (attr
, name
, where
))
1081 if (attr
->threadprivate
)
1083 duplicate_attr ("THREADPRIVATE", where
);
1087 attr
->threadprivate
= 1;
1088 return check_conflict (attr
, name
, where
);
1093 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1096 if (check_used (attr
, NULL
, where
))
1101 duplicate_attr ("TARGET", where
);
1106 return check_conflict (attr
, NULL
, where
);
1111 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1114 if (check_used (attr
, name
, where
))
1117 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1119 return check_conflict (attr
, name
, where
);
1124 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1127 if (check_used (attr
, name
, where
))
1130 /* Duplicate attribute already checked for. */
1131 attr
->in_common
= 1;
1132 if (check_conflict (attr
, name
, where
) == FAILURE
)
1135 if (attr
->flavor
== FL_VARIABLE
)
1138 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1143 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1146 /* Duplicate attribute already checked for. */
1147 attr
->in_equivalence
= 1;
1148 if (check_conflict (attr
, name
, where
) == FAILURE
)
1151 if (attr
->flavor
== FL_VARIABLE
)
1154 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1159 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1162 if (check_used (attr
, name
, where
))
1166 return check_conflict (attr
, name
, where
);
1171 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1174 attr
->in_namelist
= 1;
1175 return check_conflict (attr
, name
, where
);
1180 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1183 if (check_used (attr
, name
, where
))
1187 return check_conflict (attr
, name
, where
);
1192 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1195 if (check_used (attr
, NULL
, where
))
1198 if (attr
->elemental
)
1200 duplicate_attr ("ELEMENTAL", where
);
1204 attr
->elemental
= 1;
1205 return check_conflict (attr
, NULL
, where
);
1210 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1213 if (check_used (attr
, NULL
, where
))
1218 duplicate_attr ("PURE", where
);
1223 return check_conflict (attr
, NULL
, where
);
1228 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1231 if (check_used (attr
, NULL
, where
))
1234 if (attr
->recursive
)
1236 duplicate_attr ("RECURSIVE", where
);
1240 attr
->recursive
= 1;
1241 return check_conflict (attr
, NULL
, where
);
1246 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1249 if (check_used (attr
, name
, where
))
1254 duplicate_attr ("ENTRY", where
);
1259 return check_conflict (attr
, name
, where
);
1264 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1267 if (attr
->flavor
!= FL_PROCEDURE
1268 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1272 return check_conflict (attr
, name
, where
);
1277 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1280 if (attr
->flavor
!= FL_PROCEDURE
1281 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1284 attr
->subroutine
= 1;
1285 return check_conflict (attr
, name
, where
);
1290 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1293 if (attr
->flavor
!= FL_PROCEDURE
1294 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1298 return check_conflict (attr
, name
, where
);
1303 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1306 if (check_used (attr
, NULL
, where
))
1309 if (attr
->flavor
!= FL_PROCEDURE
1310 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1313 if (attr
->procedure
)
1315 duplicate_attr ("PROCEDURE", where
);
1319 attr
->procedure
= 1;
1321 return check_conflict (attr
, NULL
, where
);
1325 /* Flavors are special because some flavors are not what Fortran
1326 considers attributes and can be reaffirmed multiple times. */
1329 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1333 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1334 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1335 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1338 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1341 if (attr
->flavor
!= FL_UNKNOWN
)
1344 where
= &gfc_current_locus
;
1347 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1348 gfc_code2string (flavors
, attr
->flavor
), name
,
1349 gfc_code2string (flavors
, f
), where
);
1351 gfc_error ("%s attribute conflicts with %s attribute at %L",
1352 gfc_code2string (flavors
, attr
->flavor
),
1353 gfc_code2string (flavors
, f
), where
);
1360 return check_conflict (attr
, name
, where
);
1365 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1366 const char *name
, locus
*where
)
1369 if (check_used (attr
, name
, where
))
1372 if (attr
->flavor
!= FL_PROCEDURE
1373 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1377 where
= &gfc_current_locus
;
1379 if (attr
->proc
!= PROC_UNKNOWN
)
1381 gfc_error ("%s procedure at %L is already declared as %s procedure",
1382 gfc_code2string (procedures
, t
), where
,
1383 gfc_code2string (procedures
, attr
->proc
));
1390 /* Statement functions are always scalar and functions. */
1391 if (t
== PROC_ST_FUNCTION
1392 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1393 || attr
->dimension
))
1396 return check_conflict (attr
, name
, where
);
1401 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1404 if (check_used (attr
, NULL
, where
))
1407 if (attr
->intent
== INTENT_UNKNOWN
)
1409 attr
->intent
= intent
;
1410 return check_conflict (attr
, NULL
, where
);
1414 where
= &gfc_current_locus
;
1416 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1417 gfc_intent_string (attr
->intent
),
1418 gfc_intent_string (intent
), where
);
1424 /* No checks for use-association in public and private statements. */
1427 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1428 const char *name
, locus
*where
)
1431 if (attr
->access
== ACCESS_UNKNOWN
)
1433 attr
->access
= access
;
1434 return check_conflict (attr
, name
, where
);
1438 where
= &gfc_current_locus
;
1439 gfc_error ("ACCESS specification at %L was already specified", where
);
1445 /* Set the is_bind_c field for the given symbol_attribute. */
1448 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1449 int is_proc_lang_bind_spec
)
1452 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1453 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1454 "variables or common blocks", where
);
1455 else if (attr
->is_bind_c
)
1456 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1458 attr
->is_bind_c
= 1;
1461 where
= &gfc_current_locus
;
1463 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1467 return check_conflict (attr
, name
, where
);
1472 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1473 gfc_formal_arglist
* formal
, locus
*where
)
1476 if (check_used (&sym
->attr
, sym
->name
, where
))
1480 where
= &gfc_current_locus
;
1482 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1483 && sym
->attr
.if_source
!= IFSRC_DECL
)
1485 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1490 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1492 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1493 "body", sym
->name
, where
);
1497 sym
->formal
= formal
;
1498 sym
->attr
.if_source
= source
;
1504 /* Add a type to a symbol. */
1507 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1512 where
= &gfc_current_locus
;
1514 if (sym
->ts
.type
!= BT_UNKNOWN
)
1516 const char *msg
= "Symbol '%s' at %L already has basic type of %s";
1517 if (!(sym
->ts
.type
== ts
->type
1518 && (sym
->attr
.flavor
== FL_PROCEDURE
|| sym
->attr
.result
))
1519 || gfc_notification_std (GFC_STD_GNU
) == ERROR
1522 gfc_error (msg
, sym
->name
, where
, gfc_basic_typename (sym
->ts
.type
));
1525 else if (gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, where
,
1526 gfc_basic_typename (sym
->ts
.type
)) == FAILURE
)
1530 flavor
= sym
->attr
.flavor
;
1532 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1533 || flavor
== FL_LABEL
1534 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1535 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1537 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1546 /* Clears all attributes. */
1549 gfc_clear_attr (symbol_attribute
*attr
)
1551 memset (attr
, 0, sizeof (symbol_attribute
));
1555 /* Check for missing attributes in the new symbol. Currently does
1556 nothing, but it's not clear that it is unnecessary yet. */
1559 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1560 locus
*where ATTRIBUTE_UNUSED
)
1567 /* Copy an attribute to a symbol attribute, bit by bit. Some
1568 attributes have a lot of side-effects but cannot be present given
1569 where we are called from, so we ignore some bits. */
1572 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1574 int is_proc_lang_bind_spec
;
1576 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1579 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1581 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1583 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1585 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1587 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1589 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1591 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1593 if (src
->threadprivate
1594 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1596 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1598 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1600 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1605 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1608 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1611 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1613 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1615 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1618 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1620 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1622 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1624 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1627 if (src
->flavor
!= FL_UNKNOWN
1628 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1631 if (src
->intent
!= INTENT_UNKNOWN
1632 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1635 if (src
->access
!= ACCESS_UNKNOWN
1636 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1639 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1642 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1644 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1647 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1649 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1653 if (src
->is_c_interop
)
1654 dest
->is_c_interop
= 1;
1658 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1660 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1662 if (src
->proc_pointer
)
1663 dest
->proc_pointer
= 1;
1672 /************** Component name management ************/
1674 /* Component names of a derived type form their own little namespaces
1675 that are separate from all other spaces. The space is composed of
1676 a singly linked list of gfc_component structures whose head is
1677 located in the parent symbol. */
1680 /* Add a component name to a symbol. The call fails if the name is
1681 already present. On success, the component pointer is modified to
1682 point to the additional component structure. */
1685 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1686 gfc_component
**component
)
1688 gfc_component
*p
, *tail
;
1692 for (p
= sym
->components
; p
; p
= p
->next
)
1694 if (strcmp (p
->name
, name
) == 0)
1696 gfc_error ("Component '%s' at %C already declared at %L",
1704 if (sym
->attr
.extension
1705 && gfc_find_component (sym
->components
->ts
.derived
, name
))
1707 gfc_error ("Component '%s' at %C already in the parent type "
1708 "at %L", name
, &sym
->components
->ts
.derived
->declared_at
);
1712 /* Allocate a new component. */
1713 p
= gfc_get_component ();
1716 sym
->components
= p
;
1720 p
->name
= gfc_get_string (name
);
1721 p
->loc
= gfc_current_locus
;
1728 /* Recursive function to switch derived types of all symbol in a
1732 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1740 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
== from
)
1741 sym
->ts
.derived
= to
;
1743 switch_types (st
->left
, from
, to
);
1744 switch_types (st
->right
, from
, to
);
1748 /* This subroutine is called when a derived type is used in order to
1749 make the final determination about which version to use. The
1750 standard requires that a type be defined before it is 'used', but
1751 such types can appear in IMPLICIT statements before the actual
1752 definition. 'Using' in this context means declaring a variable to
1753 be that type or using the type constructor.
1755 If a type is used and the components haven't been defined, then we
1756 have to have a derived type in a parent unit. We find the node in
1757 the other namespace and point the symtree node in this namespace to
1758 that node. Further reference to this name point to the correct
1759 node. If we can't find the node in a parent namespace, then we have
1762 This subroutine takes a pointer to a symbol node and returns a
1763 pointer to the translated node or NULL for an error. Usually there
1764 is no translation and we return the node we were passed. */
1767 gfc_use_derived (gfc_symbol
*sym
)
1774 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1775 return sym
; /* Already defined. */
1777 if (sym
->ns
->parent
== NULL
)
1780 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1782 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1786 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1789 /* Get rid of symbol sym, translating all references to s. */
1790 for (i
= 0; i
< GFC_LETTERS
; i
++)
1792 t
= &sym
->ns
->default_type
[i
];
1793 if (t
->derived
== sym
)
1797 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1802 /* Unlink from list of modified symbols. */
1803 gfc_commit_symbol (sym
);
1805 switch_types (sym
->ns
->sym_root
, sym
, s
);
1807 /* TODO: Also have to replace sym -> s in other lists like
1808 namelists, common lists and interface lists. */
1809 gfc_free_symbol (sym
);
1814 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1820 /* Given a derived type node and a component name, try to locate the
1821 component structure. Returns the NULL pointer if the component is
1822 not found or the components are private. */
1825 gfc_find_component (gfc_symbol
*sym
, const char *name
)
1832 sym
= gfc_use_derived (sym
);
1837 for (p
= sym
->components
; p
; p
= p
->next
)
1838 if (strcmp (p
->name
, name
) == 0)
1842 && sym
->attr
.extension
1843 && sym
->components
->ts
.type
== BT_DERIVED
)
1845 p
= gfc_find_component (sym
->components
->ts
.derived
, name
);
1846 /* Do not overwrite the error. */
1852 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1855 else if (sym
->attr
.use_assoc
)
1857 if (p
->access
== ACCESS_PRIVATE
)
1859 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1864 /* If there were components given and all components are private, error
1865 out at this place. */
1866 if (p
->access
!= ACCESS_PUBLIC
&& sym
->component_access
== ACCESS_PRIVATE
)
1868 gfc_error ("All components of '%s' are PRIVATE in structure"
1869 " constructor at %C", sym
->name
);
1878 /* Given a symbol, free all of the component structures and everything
1882 free_components (gfc_component
*p
)
1890 gfc_free_array_spec (p
->as
);
1891 gfc_free_expr (p
->initializer
);
1898 /* Set component attributes from a standard symbol attribute structure. */
1901 gfc_set_component_attr (gfc_component
*c
, symbol_attribute
*attr
)
1904 c
->dimension
= attr
->dimension
;
1905 c
->pointer
= attr
->pointer
;
1906 c
->allocatable
= attr
->allocatable
;
1907 c
->access
= attr
->access
;
1911 /* Get a standard symbol attribute structure given the component
1915 gfc_get_component_attr (symbol_attribute
*attr
, gfc_component
*c
)
1918 gfc_clear_attr (attr
);
1919 attr
->dimension
= c
->dimension
;
1920 attr
->pointer
= c
->pointer
;
1921 attr
->allocatable
= c
->allocatable
;
1922 attr
->access
= c
->access
;
1926 /******************** Statement label management ********************/
1928 /* Comparison function for statement labels, used for managing the
1932 compare_st_labels (void *a1
, void *b1
)
1934 int a
= ((gfc_st_label
*) a1
)->value
;
1935 int b
= ((gfc_st_label
*) b1
)->value
;
1941 /* Free a single gfc_st_label structure, making sure the tree is not
1942 messed up. This function is called only when some parse error
1946 gfc_free_st_label (gfc_st_label
*label
)
1952 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
1954 if (label
->format
!= NULL
)
1955 gfc_free_expr (label
->format
);
1961 /* Free a whole tree of gfc_st_label structures. */
1964 free_st_labels (gfc_st_label
*label
)
1970 free_st_labels (label
->left
);
1971 free_st_labels (label
->right
);
1973 if (label
->format
!= NULL
)
1974 gfc_free_expr (label
->format
);
1979 /* Given a label number, search for and return a pointer to the label
1980 structure, creating it if it does not exist. */
1983 gfc_get_st_label (int labelno
)
1987 /* First see if the label is already in this namespace. */
1988 lp
= gfc_current_ns
->st_labels
;
1991 if (lp
->value
== labelno
)
1994 if (lp
->value
< labelno
)
2000 lp
= XCNEW (gfc_st_label
);
2002 lp
->value
= labelno
;
2003 lp
->defined
= ST_LABEL_UNKNOWN
;
2004 lp
->referenced
= ST_LABEL_UNKNOWN
;
2006 gfc_insert_bbt (&gfc_current_ns
->st_labels
, lp
, compare_st_labels
);
2012 /* Called when a statement with a statement label is about to be
2013 accepted. We add the label to the list of the current namespace,
2014 making sure it hasn't been defined previously and referenced
2018 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2022 labelno
= lp
->value
;
2024 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2025 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2026 &lp
->where
, label_locus
);
2029 lp
->where
= *label_locus
;
2033 case ST_LABEL_FORMAT
:
2034 if (lp
->referenced
== ST_LABEL_TARGET
)
2035 gfc_error ("Label %d at %C already referenced as branch target",
2038 lp
->defined
= ST_LABEL_FORMAT
;
2042 case ST_LABEL_TARGET
:
2043 if (lp
->referenced
== ST_LABEL_FORMAT
)
2044 gfc_error ("Label %d at %C already referenced as a format label",
2047 lp
->defined
= ST_LABEL_TARGET
;
2052 lp
->defined
= ST_LABEL_BAD_TARGET
;
2053 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2059 /* Reference a label. Given a label and its type, see if that
2060 reference is consistent with what is known about that label,
2061 updating the unknown state. Returns FAILURE if something goes
2065 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2067 gfc_sl_type label_type
;
2074 labelno
= lp
->value
;
2076 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2077 label_type
= lp
->defined
;
2080 label_type
= lp
->referenced
;
2081 lp
->where
= gfc_current_locus
;
2084 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2086 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2091 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2092 && type
== ST_LABEL_FORMAT
)
2094 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2099 lp
->referenced
= type
;
2107 /*******A helper function for creating new expressions*************/
2111 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2114 lval
= gfc_get_expr ();
2115 lval
->expr_type
= EXPR_VARIABLE
;
2116 lval
->where
= sym
->declared_at
;
2118 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2120 /* It will always be a full array. */
2121 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2124 lval
->ref
= gfc_get_ref ();
2125 lval
->ref
->type
= REF_ARRAY
;
2126 lval
->ref
->u
.ar
.type
= AR_FULL
;
2127 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2128 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2129 lval
->ref
->u
.ar
.as
= sym
->as
;
2136 /************** Symbol table management subroutines ****************/
2138 /* Basic details: Fortran 95 requires a potentially unlimited number
2139 of distinct namespaces when compiling a program unit. This case
2140 occurs during a compilation of internal subprograms because all of
2141 the internal subprograms must be read before we can start
2142 generating code for the host.
2144 Given the tricky nature of the Fortran grammar, we must be able to
2145 undo changes made to a symbol table if the current interpretation
2146 of a statement is found to be incorrect. Whenever a symbol is
2147 looked up, we make a copy of it and link to it. All of these
2148 symbols are kept in a singly linked list so that we can commit or
2149 undo the changes at a later time.
2151 A symtree may point to a symbol node outside of its namespace. In
2152 this case, that symbol has been used as a host associated variable
2153 at some previous time. */
2155 /* Allocate a new namespace structure. Copies the implicit types from
2156 PARENT if PARENT_TYPES is set. */
2159 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2163 gfc_intrinsic_op in
;
2166 ns
= XCNEW (gfc_namespace
);
2167 ns
->sym_root
= NULL
;
2168 ns
->uop_root
= NULL
;
2169 ns
->finalizers
= NULL
;
2170 ns
->default_access
= ACCESS_UNKNOWN
;
2171 ns
->parent
= parent
;
2173 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2174 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2176 /* Initialize default implicit types. */
2177 for (i
= 'a'; i
<= 'z'; i
++)
2179 ns
->set_flag
[i
- 'a'] = 0;
2180 ts
= &ns
->default_type
[i
- 'a'];
2182 if (parent_types
&& ns
->parent
!= NULL
)
2184 /* Copy parent settings. */
2185 *ts
= ns
->parent
->default_type
[i
- 'a'];
2189 if (gfc_option
.flag_implicit_none
!= 0)
2195 if ('i' <= i
&& i
<= 'n')
2197 ts
->type
= BT_INTEGER
;
2198 ts
->kind
= gfc_default_integer_kind
;
2203 ts
->kind
= gfc_default_real_kind
;
2213 /* Comparison function for symtree nodes. */
2216 compare_symtree (void *_st1
, void *_st2
)
2218 gfc_symtree
*st1
, *st2
;
2220 st1
= (gfc_symtree
*) _st1
;
2221 st2
= (gfc_symtree
*) _st2
;
2223 return strcmp (st1
->name
, st2
->name
);
2227 /* Allocate a new symtree node and associate it with the new symbol. */
2230 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2234 st
= XCNEW (gfc_symtree
);
2235 st
->name
= gfc_get_string (name
);
2237 gfc_insert_bbt (root
, st
, compare_symtree
);
2242 /* Delete a symbol from the tree. Does not free the symbol itself! */
2245 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2247 gfc_symtree st
, *st0
;
2249 st0
= gfc_find_symtree (*root
, name
);
2251 st
.name
= gfc_get_string (name
);
2252 gfc_delete_bbt (root
, &st
, compare_symtree
);
2258 /* Given a root symtree node and a name, try to find the symbol within
2259 the namespace. Returns NULL if the symbol is not found. */
2262 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2268 c
= strcmp (name
, st
->name
);
2272 st
= (c
< 0) ? st
->left
: st
->right
;
2279 /* Return a symtree node with a name that is guaranteed to be unique
2280 within the namespace and corresponds to an illegal fortran name. */
2283 gfc_get_unique_symtree (gfc_namespace
*ns
)
2285 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2286 static int serial
= 0;
2288 sprintf (name
, "@%d", serial
++);
2289 return gfc_new_symtree (&ns
->sym_root
, name
);
2293 /* Given a name find a user operator node, creating it if it doesn't
2294 exist. These are much simpler than symbols because they can't be
2295 ambiguous with one another. */
2298 gfc_get_uop (const char *name
)
2303 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2307 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2309 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2310 uop
->name
= gfc_get_string (name
);
2311 uop
->access
= ACCESS_UNKNOWN
;
2312 uop
->ns
= gfc_current_ns
;
2318 /* Given a name find the user operator node. Returns NULL if it does
2322 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2327 ns
= gfc_current_ns
;
2329 st
= gfc_find_symtree (ns
->uop_root
, name
);
2330 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2334 /* Remove a gfc_symbol structure and everything it points to. */
2337 gfc_free_symbol (gfc_symbol
*sym
)
2343 gfc_free_array_spec (sym
->as
);
2345 free_components (sym
->components
);
2347 gfc_free_expr (sym
->value
);
2349 gfc_free_namelist (sym
->namelist
);
2351 gfc_free_namespace (sym
->formal_ns
);
2353 if (!sym
->attr
.generic_copy
)
2354 gfc_free_interface (sym
->generic
);
2356 gfc_free_formal_arglist (sym
->formal
);
2358 gfc_free_namespace (sym
->f2k_derived
);
2364 /* Allocate and initialize a new symbol node. */
2367 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2371 p
= XCNEW (gfc_symbol
);
2373 gfc_clear_ts (&p
->ts
);
2374 gfc_clear_attr (&p
->attr
);
2377 p
->declared_at
= gfc_current_locus
;
2379 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2380 gfc_internal_error ("new_symbol(): Symbol name too long");
2382 p
->name
= gfc_get_string (name
);
2384 /* Make sure flags for symbol being C bound are clear initially. */
2385 p
->attr
.is_bind_c
= 0;
2386 p
->attr
.is_iso_c
= 0;
2387 /* Make sure the binding label field has a Nul char to start. */
2388 p
->binding_label
[0] = '\0';
2390 /* Clear the ptrs we may need. */
2391 p
->common_block
= NULL
;
2392 p
->f2k_derived
= NULL
;
2398 /* Generate an error if a symbol is ambiguous. */
2401 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2404 if (st
->n
.sym
->module
)
2405 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2406 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2408 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2409 "from current program unit", name
, st
->n
.sym
->name
);
2413 /* Search for a symtree starting in the current namespace, resorting to
2414 any parent namespaces if requested by a nonzero parent_flag.
2415 Returns nonzero if the name is ambiguous. */
2418 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2419 gfc_symtree
**result
)
2424 ns
= gfc_current_ns
;
2428 st
= gfc_find_symtree (ns
->sym_root
, name
);
2432 /* Ambiguous generic interfaces are permitted, as long
2433 as the specific interfaces are different. */
2434 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2436 ambiguous_symbol (name
, st
);
2455 /* Same, but returns the symbol instead. */
2458 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2459 gfc_symbol
**result
)
2464 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2469 *result
= st
->n
.sym
;
2475 /* Save symbol with the information necessary to back it out. */
2478 save_symbol_data (gfc_symbol
*sym
)
2481 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2484 sym
->old_symbol
= XCNEW (gfc_symbol
);
2485 *(sym
->old_symbol
) = *sym
;
2487 sym
->tlink
= changed_syms
;
2492 /* Given a name, find a symbol, or create it if it does not exist yet
2493 in the current namespace. If the symbol is found we make sure that
2496 The integer return code indicates
2498 1 The symbol name was ambiguous
2499 2 The name meant to be established was already host associated.
2501 So if the return value is nonzero, then an error was issued. */
2504 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
)
2509 /* This doesn't usually happen during resolution. */
2511 ns
= gfc_current_ns
;
2513 /* Try to find the symbol in ns. */
2514 st
= gfc_find_symtree (ns
->sym_root
, name
);
2518 /* If not there, create a new symbol. */
2519 p
= gfc_new_symbol (name
, ns
);
2521 /* Add to the list of tentative symbols. */
2522 p
->old_symbol
= NULL
;
2523 p
->tlink
= changed_syms
;
2528 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2535 /* Make sure the existing symbol is OK. Ambiguous
2536 generic interfaces are permitted, as long as the
2537 specific interfaces are different. */
2538 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2540 ambiguous_symbol (name
, st
);
2546 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2548 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2549 && (ns
->has_import_set
|| p
->attr
.imported
)))
2551 /* Symbol is from another namespace. */
2552 gfc_error ("Symbol '%s' at %C has already been host associated",
2559 /* Copy in case this symbol is changed. */
2560 save_symbol_data (p
);
2569 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2574 i
= gfc_get_sym_tree (name
, ns
, &st
);
2579 *result
= st
->n
.sym
;
2586 /* Subroutine that searches for a symbol, creating it if it doesn't
2587 exist, but tries to host-associate the symbol if possible. */
2590 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2595 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2598 save_symbol_data (st
->n
.sym
);
2603 if (gfc_current_ns
->parent
!= NULL
)
2605 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2616 return gfc_get_sym_tree (name
, gfc_current_ns
, result
);
2621 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2626 i
= gfc_get_ha_sym_tree (name
, &st
);
2629 *result
= st
->n
.sym
;
2636 /* Return true if both symbols could refer to the same data object. Does
2637 not take account of aliasing due to equivalence statements. */
2640 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2642 /* Aliasing isn't possible if the symbols have different base types. */
2643 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2646 /* Pointers can point to other pointers, target objects and allocatable
2647 objects. Two allocatable objects cannot share the same storage. */
2648 if (lsym
->attr
.pointer
2649 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2651 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2653 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2660 /* Undoes all the changes made to symbols in the current statement.
2661 This subroutine is made simpler due to the fact that attributes are
2662 never removed once added. */
2665 gfc_undo_symbols (void)
2667 gfc_symbol
*p
, *q
, *old
;
2669 for (p
= changed_syms
; p
; p
= q
)
2675 /* Symbol was new. */
2676 if (p
->attr
.in_common
&& p
->common_block
->head
)
2678 /* If the symbol was added to any common block, it
2679 needs to be removed to stop the resolver looking
2680 for a (possibly) dead symbol. */
2682 if (p
->common_block
->head
== p
)
2683 p
->common_block
->head
= p
->common_next
;
2686 gfc_symbol
*cparent
, *csym
;
2688 cparent
= p
->common_block
->head
;
2689 csym
= cparent
->common_next
;
2694 csym
= csym
->common_next
;
2697 gcc_assert(cparent
->common_next
== p
);
2699 cparent
->common_next
= csym
->common_next
;
2703 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2707 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2709 gfc_free_symbol (p
);
2713 /* Restore previous state of symbol. Just copy simple stuff. */
2715 old
= p
->old_symbol
;
2717 p
->ts
.type
= old
->ts
.type
;
2718 p
->ts
.kind
= old
->ts
.kind
;
2720 p
->attr
= old
->attr
;
2722 if (p
->value
!= old
->value
)
2724 gfc_free_expr (old
->value
);
2728 if (p
->as
!= old
->as
)
2731 gfc_free_array_spec (p
->as
);
2735 p
->generic
= old
->generic
;
2736 p
->component_access
= old
->component_access
;
2738 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2740 gfc_free_namelist (p
->namelist
);
2745 if (p
->namelist_tail
!= old
->namelist_tail
)
2747 gfc_free_namelist (old
->namelist_tail
);
2748 old
->namelist_tail
->next
= NULL
;
2752 p
->namelist_tail
= old
->namelist_tail
;
2754 if (p
->formal
!= old
->formal
)
2756 gfc_free_formal_arglist (p
->formal
);
2757 p
->formal
= old
->formal
;
2760 gfc_free (p
->old_symbol
);
2761 p
->old_symbol
= NULL
;
2765 changed_syms
= NULL
;
2769 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2770 components of old_symbol that might need deallocation are the "allocatables"
2771 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2772 namelist_tail. In case these differ between old_symbol and sym, it's just
2773 because sym->namelist has gotten a few more items. */
2776 free_old_symbol (gfc_symbol
*sym
)
2779 if (sym
->old_symbol
== NULL
)
2782 if (sym
->old_symbol
->as
!= sym
->as
)
2783 gfc_free_array_spec (sym
->old_symbol
->as
);
2785 if (sym
->old_symbol
->value
!= sym
->value
)
2786 gfc_free_expr (sym
->old_symbol
->value
);
2788 if (sym
->old_symbol
->formal
!= sym
->formal
)
2789 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2791 gfc_free (sym
->old_symbol
);
2792 sym
->old_symbol
= NULL
;
2796 /* Makes the changes made in the current statement permanent-- gets
2797 rid of undo information. */
2800 gfc_commit_symbols (void)
2804 for (p
= changed_syms
; p
; p
= q
)
2810 free_old_symbol (p
);
2812 changed_syms
= NULL
;
2816 /* Makes the changes made in one symbol permanent -- gets rid of undo
2820 gfc_commit_symbol (gfc_symbol
*sym
)
2824 if (changed_syms
== sym
)
2825 changed_syms
= sym
->tlink
;
2828 for (p
= changed_syms
; p
; p
= p
->tlink
)
2829 if (p
->tlink
== sym
)
2831 p
->tlink
= sym
->tlink
;
2840 free_old_symbol (sym
);
2844 /* Recursive function that deletes an entire tree and all the common
2845 head structures it points to. */
2848 free_common_tree (gfc_symtree
* common_tree
)
2850 if (common_tree
== NULL
)
2853 free_common_tree (common_tree
->left
);
2854 free_common_tree (common_tree
->right
);
2856 gfc_free (common_tree
);
2860 /* Recursive function that deletes an entire tree and all the user
2861 operator nodes that it contains. */
2864 free_uop_tree (gfc_symtree
*uop_tree
)
2867 if (uop_tree
== NULL
)
2870 free_uop_tree (uop_tree
->left
);
2871 free_uop_tree (uop_tree
->right
);
2873 gfc_free_interface (uop_tree
->n
.uop
->op
);
2875 gfc_free (uop_tree
->n
.uop
);
2876 gfc_free (uop_tree
);
2880 /* Recursive function that deletes an entire tree and all the symbols
2881 that it contains. */
2884 free_sym_tree (gfc_symtree
*sym_tree
)
2889 if (sym_tree
== NULL
)
2892 free_sym_tree (sym_tree
->left
);
2893 free_sym_tree (sym_tree
->right
);
2895 sym
= sym_tree
->n
.sym
;
2899 gfc_internal_error ("free_sym_tree(): Negative refs");
2901 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
2903 /* As formal_ns contains a reference to sym, delete formal_ns just
2904 before the deletion of sym. */
2905 ns
= sym
->formal_ns
;
2906 sym
->formal_ns
= NULL
;
2907 gfc_free_namespace (ns
);
2909 else if (sym
->refs
== 0)
2911 /* Go ahead and delete the symbol. */
2912 gfc_free_symbol (sym
);
2915 gfc_free (sym_tree
);
2919 /* Free the derived type list. */
2922 gfc_free_dt_list (void)
2924 gfc_dt_list
*dt
, *n
;
2926 for (dt
= gfc_derived_types
; dt
; dt
= n
)
2932 gfc_derived_types
= NULL
;
2936 /* Free the gfc_equiv_info's. */
2939 gfc_free_equiv_infos (gfc_equiv_info
*s
)
2943 gfc_free_equiv_infos (s
->next
);
2948 /* Free the gfc_equiv_lists. */
2951 gfc_free_equiv_lists (gfc_equiv_list
*l
)
2955 gfc_free_equiv_lists (l
->next
);
2956 gfc_free_equiv_infos (l
->equiv
);
2961 /* Free a finalizer procedure list. */
2964 gfc_free_finalizer (gfc_finalizer
* el
)
2970 --el
->proc_sym
->refs
;
2971 if (!el
->proc_sym
->refs
)
2972 gfc_free_symbol (el
->proc_sym
);
2980 gfc_free_finalizer_list (gfc_finalizer
* list
)
2984 gfc_finalizer
* current
= list
;
2986 gfc_free_finalizer (current
);
2991 /* Free a namespace structure and everything below it. Interface
2992 lists associated with intrinsic operators are not freed. These are
2993 taken care of when a specific name is freed. */
2996 gfc_free_namespace (gfc_namespace
*ns
)
2998 gfc_charlen
*cl
, *cl2
;
2999 gfc_namespace
*p
, *q
;
3008 gcc_assert (ns
->refs
== 0);
3010 gfc_free_statements (ns
->code
);
3012 free_sym_tree (ns
->sym_root
);
3013 free_uop_tree (ns
->uop_root
);
3014 free_common_tree (ns
->common_root
);
3015 gfc_free_finalizer_list (ns
->finalizers
);
3017 for (cl
= ns
->cl_list
; cl
; cl
= cl2
)
3020 gfc_free_expr (cl
->length
);
3024 free_st_labels (ns
->st_labels
);
3026 gfc_free_equiv (ns
->equiv
);
3027 gfc_free_equiv_lists (ns
->equiv_lists
);
3029 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3030 gfc_free_interface (ns
->op
[i
]);
3032 gfc_free_data (ns
->data
);
3036 /* Recursively free any contained namespaces. */
3041 gfc_free_namespace (q
);
3047 gfc_symbol_init_2 (void)
3050 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3055 gfc_symbol_done_2 (void)
3058 gfc_free_namespace (gfc_current_ns
);
3059 gfc_current_ns
= NULL
;
3060 gfc_free_dt_list ();
3064 /* Clear mark bits from symbol nodes associated with a symtree node. */
3067 clear_sym_mark (gfc_symtree
*st
)
3070 st
->n
.sym
->mark
= 0;
3074 /* Recursively traverse the symtree nodes. */
3077 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
3082 gfc_traverse_symtree (st
->left
, func
);
3084 gfc_traverse_symtree (st
->right
, func
);
3088 /* Recursive namespace traversal function. */
3091 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
3097 traverse_ns (st
->left
, func
);
3099 if (st
->n
.sym
->mark
== 0)
3100 (*func
) (st
->n
.sym
);
3101 st
->n
.sym
->mark
= 1;
3103 traverse_ns (st
->right
, func
);
3107 /* Call a given function for all symbols in the namespace. We take
3108 care that each gfc_symbol node is called exactly once. */
3111 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3114 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3116 traverse_ns (ns
->sym_root
, func
);
3120 /* Return TRUE when name is the name of an intrinsic type. */
3123 gfc_is_intrinsic_typename (const char *name
)
3125 if (strcmp (name
, "integer") == 0
3126 || strcmp (name
, "real") == 0
3127 || strcmp (name
, "character") == 0
3128 || strcmp (name
, "logical") == 0
3129 || strcmp (name
, "complex") == 0
3130 || strcmp (name
, "doubleprecision") == 0
3131 || strcmp (name
, "doublecomplex") == 0)
3138 /* Return TRUE if the symbol is an automatic variable. */
3141 gfc_is_var_automatic (gfc_symbol
*sym
)
3143 /* Pointer and allocatable variables are never automatic. */
3144 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3146 /* Check for arrays with non-constant size. */
3147 if (sym
->attr
.dimension
&& sym
->as
3148 && !gfc_is_compile_time_shape (sym
->as
))
3150 /* Check for non-constant length character variables. */
3151 if (sym
->ts
.type
== BT_CHARACTER
3153 && !gfc_is_constant_expr (sym
->ts
.cl
->length
))
3158 /* Given a symbol, mark it as SAVEd if it is allowed. */
3161 save_symbol (gfc_symbol
*sym
)
3164 if (sym
->attr
.use_assoc
)
3167 if (sym
->attr
.in_common
3169 || sym
->attr
.flavor
!= FL_VARIABLE
)
3171 /* Automatic objects are not saved. */
3172 if (gfc_is_var_automatic (sym
))
3174 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3178 /* Mark those symbols which can be SAVEd as such. */
3181 gfc_save_all (gfc_namespace
*ns
)
3184 gfc_traverse_ns (ns
, save_symbol
);
3189 /* Make sure that no changes to symbols are pending. */
3192 gfc_symbol_state(void) {
3194 if (changed_syms
!= NULL
)
3195 gfc_internal_error("Symbol changes still pending!");
3200 /************** Global symbol handling ************/
3203 /* Search a tree for the global symbol. */
3206 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3215 c
= strcmp (name
, symbol
->name
);
3219 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3226 /* Compare two global symbols. Used for managing the BB tree. */
3229 gsym_compare (void *_s1
, void *_s2
)
3231 gfc_gsymbol
*s1
, *s2
;
3233 s1
= (gfc_gsymbol
*) _s1
;
3234 s2
= (gfc_gsymbol
*) _s2
;
3235 return strcmp (s1
->name
, s2
->name
);
3239 /* Get a global symbol, creating it if it doesn't exist. */
3242 gfc_get_gsymbol (const char *name
)
3246 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3250 s
= XCNEW (gfc_gsymbol
);
3251 s
->type
= GSYM_UNKNOWN
;
3252 s
->name
= gfc_get_string (name
);
3254 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3261 get_iso_c_binding_dt (int sym_id
)
3263 gfc_dt_list
*dt_list
;
3265 dt_list
= gfc_derived_types
;
3267 /* Loop through the derived types in the name list, searching for
3268 the desired symbol from iso_c_binding. Search the parent namespaces
3269 if necessary and requested to (parent_flag). */
3270 while (dt_list
!= NULL
)
3272 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3273 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3274 return dt_list
->derived
;
3276 dt_list
= dt_list
->next
;
3283 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3284 with C. This is necessary for any derived type that is BIND(C) and for
3285 derived types that are parameters to functions that are BIND(C). All
3286 fields of the derived type are required to be interoperable, and are tested
3287 for such. If an error occurs, the errors are reported here, allowing for
3288 multiple errors to be handled for a single derived type. */
3291 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3293 gfc_component
*curr_comp
= NULL
;
3294 gfc_try is_c_interop
= FAILURE
;
3295 gfc_try retval
= SUCCESS
;
3297 if (derived_sym
== NULL
)
3298 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3299 "unexpectedly NULL");
3301 /* If we've already looked at this derived symbol, do not look at it again
3302 so we don't repeat warnings/errors. */
3303 if (derived_sym
->ts
.is_c_interop
)
3306 /* The derived type must have the BIND attribute to be interoperable
3307 J3/04-007, Section 15.2.3. */
3308 if (derived_sym
->attr
.is_bind_c
!= 1)
3310 derived_sym
->ts
.is_c_interop
= 0;
3311 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3312 "attribute to be C interoperable", derived_sym
->name
,
3313 &(derived_sym
->declared_at
));
3317 curr_comp
= derived_sym
->components
;
3319 /* TODO: is this really an error? */
3320 if (curr_comp
== NULL
)
3322 gfc_error ("Derived type '%s' at %L is empty",
3323 derived_sym
->name
, &(derived_sym
->declared_at
));
3327 /* Initialize the derived type as being C interoperable.
3328 If we find an error in the components, this will be set false. */
3329 derived_sym
->ts
.is_c_interop
= 1;
3331 /* Loop through the list of components to verify that the kind of
3332 each is a C interoperable type. */
3335 /* The components cannot be pointers (fortran sense).
3336 J3/04-007, Section 15.2.3, C1505. */
3337 if (curr_comp
->pointer
!= 0)
3339 gfc_error ("Component '%s' at %L cannot have the "
3340 "POINTER attribute because it is a member "
3341 "of the BIND(C) derived type '%s' at %L",
3342 curr_comp
->name
, &(curr_comp
->loc
),
3343 derived_sym
->name
, &(derived_sym
->declared_at
));
3347 /* The components cannot be allocatable.
3348 J3/04-007, Section 15.2.3, C1505. */
3349 if (curr_comp
->allocatable
!= 0)
3351 gfc_error ("Component '%s' at %L cannot have the "
3352 "ALLOCATABLE attribute because it is a member "
3353 "of the BIND(C) derived type '%s' at %L",
3354 curr_comp
->name
, &(curr_comp
->loc
),
3355 derived_sym
->name
, &(derived_sym
->declared_at
));
3359 /* BIND(C) derived types must have interoperable components. */
3360 if (curr_comp
->ts
.type
== BT_DERIVED
3361 && curr_comp
->ts
.derived
->ts
.is_iso_c
!= 1
3362 && curr_comp
->ts
.derived
!= derived_sym
)
3364 /* This should be allowed; the draft says a derived-type can not
3365 have type parameters if it is has the BIND attribute. Type
3366 parameters seem to be for making parameterized derived types.
3367 There's no need to verify the type if it is c_ptr/c_funptr. */
3368 retval
= verify_bind_c_derived_type (curr_comp
->ts
.derived
);
3372 /* Grab the typespec for the given component and test the kind. */
3373 is_c_interop
= verify_c_interop (&(curr_comp
->ts
), curr_comp
->name
,
3376 if (is_c_interop
!= SUCCESS
)
3378 /* Report warning and continue since not fatal. The
3379 draft does specify a constraint that requires all fields
3380 to interoperate, but if the user says real(4), etc., it
3381 may interoperate with *something* in C, but the compiler
3382 most likely won't know exactly what. Further, it may not
3383 interoperate with the same data type(s) in C if the user
3384 recompiles with different flags (e.g., -m32 and -m64 on
3385 x86_64 and using integer(4) to claim interop with a
3387 if (derived_sym
->attr
.is_bind_c
== 1)
3388 /* If the derived type is bind(c), all fields must be
3390 gfc_warning ("Component '%s' in derived type '%s' at %L "
3391 "may not be C interoperable, even though "
3392 "derived type '%s' is BIND(C)",
3393 curr_comp
->name
, derived_sym
->name
,
3394 &(curr_comp
->loc
), derived_sym
->name
);
3396 /* If derived type is param to bind(c) routine, or to one
3397 of the iso_c_binding procs, it must be interoperable, so
3398 all fields must interop too. */
3399 gfc_warning ("Component '%s' in derived type '%s' at %L "
3400 "may not be C interoperable",
3401 curr_comp
->name
, derived_sym
->name
,
3406 curr_comp
= curr_comp
->next
;
3407 } while (curr_comp
!= NULL
);
3410 /* Make sure we don't have conflicts with the attributes. */
3411 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3413 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3414 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3415 &(derived_sym
->declared_at
));
3419 if (derived_sym
->attr
.sequence
!= 0)
3421 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3422 "attribute because it is BIND(C)", derived_sym
->name
,
3423 &(derived_sym
->declared_at
));
3427 /* Mark the derived type as not being C interoperable if we found an
3428 error. If there were only warnings, proceed with the assumption
3429 it's interoperable. */
3430 if (retval
== FAILURE
)
3431 derived_sym
->ts
.is_c_interop
= 0;
3437 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3440 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3441 const char *module_name
)
3443 gfc_symtree
*tmp_symtree
;
3444 gfc_symbol
*tmp_sym
;
3446 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3448 if (tmp_symtree
!= NULL
)
3449 tmp_sym
= tmp_symtree
->n
.sym
;
3453 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3454 "create symbol for %s", ptr_name
);
3457 /* Set up the symbol's important fields. Save attr required so we can
3458 initialize the ptr to NULL. */
3459 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3460 tmp_sym
->ts
.is_c_interop
= 1;
3461 tmp_sym
->attr
.is_c_interop
= 1;
3462 tmp_sym
->ts
.is_iso_c
= 1;
3463 tmp_sym
->ts
.type
= BT_DERIVED
;
3465 /* The c_ptr and c_funptr derived types will provide the
3466 definition for c_null_ptr and c_null_funptr, respectively. */
3467 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3468 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3470 tmp_sym
->ts
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3471 if (tmp_sym
->ts
.derived
== NULL
)
3473 /* This can occur if the user forgot to declare c_ptr or
3474 c_funptr and they're trying to use one of the procedures
3475 that has arg(s) of the missing type. In this case, a
3476 regular version of the thing should have been put in the
3478 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3479 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3480 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3481 ? "_gfortran_iso_c_binding_c_ptr"
3482 : "_gfortran_iso_c_binding_c_funptr"));
3484 tmp_sym
->ts
.derived
=
3485 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3486 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3489 /* Module name is some mangled version of iso_c_binding. */
3490 tmp_sym
->module
= gfc_get_string (module_name
);
3492 /* Say it's from the iso_c_binding module. */
3493 tmp_sym
->attr
.is_iso_c
= 1;
3495 tmp_sym
->attr
.use_assoc
= 1;
3496 tmp_sym
->attr
.is_bind_c
= 1;
3497 /* Set the binding_label. */
3498 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3500 /* Set the c_address field of c_null_ptr and c_null_funptr to
3501 the value of NULL. */
3502 tmp_sym
->value
= gfc_get_expr ();
3503 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3504 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3505 tmp_sym
->value
->ts
.derived
= tmp_sym
->ts
.derived
;
3506 /* Create a constructor with no expr, that way we can recognize if the user
3507 tries to call the structure constructor for one of the iso_c_binding
3508 derived types during resolution (resolve_structure_cons). */
3509 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3510 /* Must declare c_null_ptr and c_null_funptr as having the
3511 PARAMETER attribute so they can be used in init expressions. */
3512 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3518 /* Add a formal argument, gfc_formal_arglist, to the
3519 end of the given list of arguments. Set the reference to the
3520 provided symbol, param_sym, in the argument. */
3523 add_formal_arg (gfc_formal_arglist
**head
,
3524 gfc_formal_arglist
**tail
,
3525 gfc_formal_arglist
*formal_arg
,
3526 gfc_symbol
*param_sym
)
3528 /* Put in list, either as first arg or at the tail (curr arg). */
3530 *head
= *tail
= formal_arg
;
3533 (*tail
)->next
= formal_arg
;
3534 (*tail
) = formal_arg
;
3537 (*tail
)->sym
= param_sym
;
3538 (*tail
)->next
= NULL
;
3544 /* Generates a symbol representing the CPTR argument to an
3545 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3546 CPTR and add it to the provided argument list. */
3549 gen_cptr_param (gfc_formal_arglist
**head
,
3550 gfc_formal_arglist
**tail
,
3551 const char *module_name
,
3552 gfc_namespace
*ns
, const char *c_ptr_name
,
3555 gfc_symbol
*param_sym
= NULL
;
3556 gfc_symbol
*c_ptr_sym
= NULL
;
3557 gfc_symtree
*param_symtree
= NULL
;
3558 gfc_formal_arglist
*formal_arg
= NULL
;
3559 const char *c_ptr_in
;
3560 const char *c_ptr_type
= NULL
;
3562 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3563 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3565 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3567 if(c_ptr_name
== NULL
)
3568 c_ptr_in
= "gfc_cptr__";
3570 c_ptr_in
= c_ptr_name
;
3571 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
);
3572 if (param_symtree
!= NULL
)
3573 param_sym
= param_symtree
->n
.sym
;
3575 gfc_internal_error ("gen_cptr_param(): Unable to "
3576 "create symbol for %s", c_ptr_in
);
3578 /* Set up the appropriate fields for the new c_ptr param sym. */
3580 param_sym
->attr
.flavor
= FL_DERIVED
;
3581 param_sym
->ts
.type
= BT_DERIVED
;
3582 param_sym
->attr
.intent
= INTENT_IN
;
3583 param_sym
->attr
.dummy
= 1;
3585 /* This will pass the ptr to the iso_c routines as a (void *). */
3586 param_sym
->attr
.value
= 1;
3587 param_sym
->attr
.use_assoc
= 1;
3589 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3591 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3592 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3594 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3595 if (c_ptr_sym
== NULL
)
3597 /* This can happen if the user did not define c_ptr but they are
3598 trying to use one of the iso_c_binding functions that need it. */
3599 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3600 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3601 (const char *)c_ptr_type
);
3603 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3604 (const char *)c_ptr_type
);
3606 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3609 param_sym
->ts
.derived
= c_ptr_sym
;
3610 param_sym
->module
= gfc_get_string (module_name
);
3612 /* Make new formal arg. */
3613 formal_arg
= gfc_get_formal_arglist ();
3614 /* Add arg to list of formal args (the CPTR arg). */
3615 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3619 /* Generates a symbol representing the FPTR argument to an
3620 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3621 FPTR and add it to the provided argument list. */
3624 gen_fptr_param (gfc_formal_arglist
**head
,
3625 gfc_formal_arglist
**tail
,
3626 const char *module_name
,
3627 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3629 gfc_symbol
*param_sym
= NULL
;
3630 gfc_symtree
*param_symtree
= NULL
;
3631 gfc_formal_arglist
*formal_arg
= NULL
;
3632 const char *f_ptr_out
= "gfc_fptr__";
3634 if (f_ptr_name
!= NULL
)
3635 f_ptr_out
= f_ptr_name
;
3637 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
);
3638 if (param_symtree
!= NULL
)
3639 param_sym
= param_symtree
->n
.sym
;
3641 gfc_internal_error ("generateFPtrParam(): Unable to "
3642 "create symbol for %s", f_ptr_out
);
3644 /* Set up the necessary fields for the fptr output param sym. */
3647 param_sym
->attr
.proc_pointer
= 1;
3649 param_sym
->attr
.pointer
= 1;
3650 param_sym
->attr
.dummy
= 1;
3651 param_sym
->attr
.use_assoc
= 1;
3653 /* ISO C Binding type to allow any pointer type as actual param. */
3654 param_sym
->ts
.type
= BT_VOID
;
3655 param_sym
->module
= gfc_get_string (module_name
);
3658 formal_arg
= gfc_get_formal_arglist ();
3659 /* Add arg to list of formal args. */
3660 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3664 /* Generates a symbol representing the optional SHAPE argument for the
3665 iso_c_binding c_f_pointer() procedure. Also, create a
3666 gfc_formal_arglist for the SHAPE and add it to the provided
3670 gen_shape_param (gfc_formal_arglist
**head
,
3671 gfc_formal_arglist
**tail
,
3672 const char *module_name
,
3673 gfc_namespace
*ns
, const char *shape_param_name
)
3675 gfc_symbol
*param_sym
= NULL
;
3676 gfc_symtree
*param_symtree
= NULL
;
3677 gfc_formal_arglist
*formal_arg
= NULL
;
3678 const char *shape_param
= "gfc_shape_array__";
3681 if (shape_param_name
!= NULL
)
3682 shape_param
= shape_param_name
;
3684 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
);
3685 if (param_symtree
!= NULL
)
3686 param_sym
= param_symtree
->n
.sym
;
3688 gfc_internal_error ("generateShapeParam(): Unable to "
3689 "create symbol for %s", shape_param
);
3691 /* Set up the necessary fields for the shape input param sym. */
3693 param_sym
->attr
.dummy
= 1;
3694 param_sym
->attr
.use_assoc
= 1;
3696 /* Integer array, rank 1, describing the shape of the object. Make it's
3697 type BT_VOID initially so we can accept any type/kind combination of
3698 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3699 of BT_INTEGER type. */
3700 param_sym
->ts
.type
= BT_VOID
;
3702 /* Initialize the kind to default integer. However, it will be overridden
3703 during resolution to match the kind of the SHAPE parameter given as
3704 the actual argument (to allow for any valid integer kind). */
3705 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3706 param_sym
->as
= gfc_get_array_spec ();
3708 /* Clear out the dimension info for the array. */
3709 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3711 param_sym
->as
->lower
[i
] = NULL
;
3712 param_sym
->as
->upper
[i
] = NULL
;
3714 param_sym
->as
->rank
= 1;
3715 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3717 /* The extent is unknown until we get it. The length give us
3718 the rank the incoming pointer. */
3719 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3721 /* The arg is also optional; it is required iff the second arg
3722 (fptr) is to an array, otherwise, it's ignored. */
3723 param_sym
->attr
.optional
= 1;
3724 param_sym
->attr
.intent
= INTENT_IN
;
3725 param_sym
->attr
.dimension
= 1;
3726 param_sym
->module
= gfc_get_string (module_name
);
3729 formal_arg
= gfc_get_formal_arglist ();
3730 /* Add arg to list of formal args. */
3731 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3734 /* Add a procedure interface to the given symbol (i.e., store a
3735 reference to the list of formal arguments). */
3738 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3739 gfc_formal_arglist
*formal
)
3742 sym
->formal
= formal
;
3743 sym
->attr
.if_source
= source
;
3746 /* Copy the formal args from an existing symbol, src, into a new
3747 symbol, dest. New formal args are created, and the description of
3748 each arg is set according to the existing ones. This function is
3749 used when creating procedure declaration variables from a procedure
3750 declaration statement (see match_proc_decl()) to create the formal
3751 args based on the args of a given named interface. */
3754 copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3756 gfc_formal_arglist
*head
= NULL
;
3757 gfc_formal_arglist
*tail
= NULL
;
3758 gfc_formal_arglist
*formal_arg
= NULL
;
3759 gfc_formal_arglist
*curr_arg
= NULL
;
3760 gfc_formal_arglist
*formal_prev
= NULL
;
3761 /* Save current namespace so we can change it for formal args. */
3762 gfc_namespace
*parent_ns
= gfc_current_ns
;
3764 /* Create a new namespace, which will be the formal ns (namespace
3765 of the formal args). */
3766 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3767 gfc_current_ns
->proc_name
= dest
;
3769 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3771 formal_arg
= gfc_get_formal_arglist ();
3772 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3774 /* May need to copy more info for the symbol. */
3775 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3776 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3777 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
3779 /* If this isn't the first arg, set up the next ptr. For the
3780 last arg built, the formal_arg->next will never get set to
3781 anything other than NULL. */
3782 if (formal_prev
!= NULL
)
3783 formal_prev
->next
= formal_arg
;
3785 formal_arg
->next
= NULL
;
3787 formal_prev
= formal_arg
;
3789 /* Add arg to list of formal args. */
3790 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3793 /* Add the interface to the symbol. */
3794 add_proc_interface (dest
, IFSRC_DECL
, head
);
3796 /* Store the formal namespace information. */
3797 if (dest
->formal
!= NULL
)
3798 /* The current ns should be that for the dest proc. */
3799 dest
->formal_ns
= gfc_current_ns
;
3800 /* Restore the current namespace to what it was on entry. */
3801 gfc_current_ns
= parent_ns
;
3804 /* Builds the parameter list for the iso_c_binding procedure
3805 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3806 generic version of either the c_f_pointer or c_f_procpointer
3807 functions. The new_proc_sym represents a "resolved" version of the
3808 symbol. The functions are resolved to match the types of their
3809 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3810 something similar to c_f_pointer_i4 if the type of data object fptr
3811 pointed to was a default integer. The actual name of the resolved
3812 procedure symbol is further mangled with the module name, etc., but
3813 the idea holds true. */
3816 build_formal_args (gfc_symbol
*new_proc_sym
,
3817 gfc_symbol
*old_sym
, int add_optional_arg
)
3819 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
3820 gfc_namespace
*parent_ns
= NULL
;
3822 parent_ns
= gfc_current_ns
;
3823 /* Create a new namespace, which will be the formal ns (namespace
3824 of the formal args). */
3825 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
3826 gfc_current_ns
->proc_name
= new_proc_sym
;
3828 /* Generate the params. */
3829 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3831 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3832 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3833 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3834 gfc_current_ns
, "fptr", 1);
3836 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3838 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3839 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
3840 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3841 gfc_current_ns
, "fptr", 0);
3842 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3843 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
3844 gfc_current_ns
, "shape");
3847 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3849 /* c_associated has one required arg and one optional; both
3851 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3852 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
3853 if (add_optional_arg
)
3855 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
3856 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
3857 /* The last param is optional so mark it as such. */
3858 tail
->sym
->attr
.optional
= 1;
3862 /* Add the interface (store formal args to new_proc_sym). */
3863 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
3865 /* Set up the formal_ns pointer to the one created for the
3866 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3867 new_proc_sym
->formal_ns
= gfc_current_ns
;
3869 gfc_current_ns
= parent_ns
;
3873 std_for_isocbinding_symbol (int id
)
3877 #define NAMED_INTCST(a,b,c,d) \
3880 #include "iso-c-binding.def"
3883 return GFC_STD_F2003
;
3887 /* Generate the given set of C interoperable kind objects, or all
3888 interoperable kinds. This function will only be given kind objects
3889 for valid iso_c_binding defined types because this is verified when
3890 the 'use' statement is parsed. If the user gives an 'only' clause,
3891 the specific kinds are looked up; if they don't exist, an error is
3892 reported. If the user does not give an 'only' clause, all
3893 iso_c_binding symbols are generated. If a list of specific kinds
3894 is given, it must have a NULL in the first empty spot to mark the
3899 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
3900 const char *local_name
)
3902 const char *const name
= (local_name
&& local_name
[0]) ? local_name
3903 : c_interop_kinds_table
[s
].name
;
3904 gfc_symtree
*tmp_symtree
= NULL
;
3905 gfc_symbol
*tmp_sym
= NULL
;
3906 gfc_dt_list
**dt_list_ptr
= NULL
;
3907 gfc_component
*tmp_comp
= NULL
;
3908 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
3911 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == FAILURE
)
3913 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3915 /* Already exists in this scope so don't re-add it.
3916 TODO: we should probably check that it's really the same symbol. */
3917 if (tmp_symtree
!= NULL
)
3920 /* Create the sym tree in the current ns. */
3921 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
3923 tmp_sym
= tmp_symtree
->n
.sym
;
3925 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3928 /* Say what module this symbol belongs to. */
3929 tmp_sym
->module
= gfc_get_string (mod_name
);
3930 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
3931 tmp_sym
->intmod_sym_id
= s
;
3936 #define NAMED_INTCST(a,b,c,d) case a :
3937 #define NAMED_REALCST(a,b,c) case a :
3938 #define NAMED_CMPXCST(a,b,c) case a :
3939 #define NAMED_LOGCST(a,b,c) case a :
3940 #define NAMED_CHARKNDCST(a,b,c) case a :
3941 #include "iso-c-binding.def"
3943 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
3945 /* Initialize an integer constant expression node. */
3946 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3947 tmp_sym
->ts
.type
= BT_INTEGER
;
3948 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
3950 /* Mark this type as a C interoperable one. */
3951 tmp_sym
->ts
.is_c_interop
= 1;
3952 tmp_sym
->ts
.is_iso_c
= 1;
3953 tmp_sym
->value
->ts
.is_c_interop
= 1;
3954 tmp_sym
->value
->ts
.is_iso_c
= 1;
3955 tmp_sym
->attr
.is_c_interop
= 1;
3957 /* Tell what f90 type this c interop kind is valid. */
3958 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
3960 /* Say it's from the iso_c_binding module. */
3961 tmp_sym
->attr
.is_iso_c
= 1;
3963 /* Make it use associated. */
3964 tmp_sym
->attr
.use_assoc
= 1;
3968 #define NAMED_CHARCST(a,b,c) case a :
3969 #include "iso-c-binding.def"
3971 /* Initialize an integer constant expression node for the
3972 length of the character. */
3973 tmp_sym
->value
= gfc_get_expr ();
3974 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
3975 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
3976 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
3977 tmp_sym
->value
->where
= gfc_current_locus
;
3978 tmp_sym
->value
->ts
.is_c_interop
= 1;
3979 tmp_sym
->value
->ts
.is_iso_c
= 1;
3980 tmp_sym
->value
->value
.character
.length
= 1;
3981 tmp_sym
->value
->value
.character
.string
= gfc_get_wide_string (2);
3982 tmp_sym
->value
->value
.character
.string
[0]
3983 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
3984 tmp_sym
->value
->value
.character
.string
[1] = '\0';
3985 tmp_sym
->ts
.cl
= gfc_get_charlen ();
3986 tmp_sym
->ts
.cl
->length
= gfc_int_expr (1);
3988 /* May not need this in both attr and ts, but do need in
3989 attr for writing module file. */
3990 tmp_sym
->attr
.is_c_interop
= 1;
3992 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3993 tmp_sym
->ts
.type
= BT_CHARACTER
;
3995 /* Need to set it to the C_CHAR kind. */
3996 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
3998 /* Mark this type as a C interoperable one. */
3999 tmp_sym
->ts
.is_c_interop
= 1;
4000 tmp_sym
->ts
.is_iso_c
= 1;
4002 /* Tell what f90 type this c interop kind is valid. */
4003 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4005 /* Say it's from the iso_c_binding module. */
4006 tmp_sym
->attr
.is_iso_c
= 1;
4008 /* Make it use associated. */
4009 tmp_sym
->attr
.use_assoc
= 1;
4012 case ISOCBINDING_PTR
:
4013 case ISOCBINDING_FUNPTR
:
4015 /* Initialize an integer constant expression node. */
4016 tmp_sym
->attr
.flavor
= FL_DERIVED
;
4017 tmp_sym
->ts
.is_c_interop
= 1;
4018 tmp_sym
->attr
.is_c_interop
= 1;
4019 tmp_sym
->attr
.is_iso_c
= 1;
4020 tmp_sym
->ts
.is_iso_c
= 1;
4021 tmp_sym
->ts
.type
= BT_DERIVED
;
4023 /* A derived type must have the bind attribute to be
4024 interoperable (J3/04-007, Section 15.2.3), even though
4025 the binding label is not used. */
4026 tmp_sym
->attr
.is_bind_c
= 1;
4028 tmp_sym
->attr
.referenced
= 1;
4030 tmp_sym
->ts
.derived
= tmp_sym
;
4032 /* Add the symbol created for the derived type to the current ns. */
4033 dt_list_ptr
= &(gfc_derived_types
);
4034 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4035 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4037 /* There is already at least one derived type in the list, so append
4038 the one we're currently building for c_ptr or c_funptr. */
4039 if (*dt_list_ptr
!= NULL
)
4040 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4041 (*dt_list_ptr
) = gfc_get_dt_list ();
4042 (*dt_list_ptr
)->derived
= tmp_sym
;
4043 (*dt_list_ptr
)->next
= NULL
;
4045 /* Set up the component of the derived type, which will be
4046 an integer with kind equal to c_ptr_size. Mangle the name of
4047 the field for the c_address to prevent the curious user from
4048 trying to access it from Fortran. */
4049 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
4050 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
4051 if (tmp_comp
== NULL
)
4052 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4053 "create component for c_address");
4055 tmp_comp
->ts
.type
= BT_INTEGER
;
4057 /* Set this because the module will need to read/write this field. */
4058 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4060 /* The kinds for c_ptr and c_funptr are the same. */
4061 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4062 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4064 tmp_comp
->pointer
= 0;
4065 tmp_comp
->dimension
= 0;
4067 /* Mark the component as C interoperable. */
4068 tmp_comp
->ts
.is_c_interop
= 1;
4070 /* Make it use associated (iso_c_binding module). */
4071 tmp_sym
->attr
.use_assoc
= 1;
4074 case ISOCBINDING_NULL_PTR
:
4075 case ISOCBINDING_NULL_FUNPTR
:
4076 gen_special_c_interop_ptr (s
, name
, mod_name
);
4079 case ISOCBINDING_F_POINTER
:
4080 case ISOCBINDING_ASSOCIATED
:
4081 case ISOCBINDING_LOC
:
4082 case ISOCBINDING_FUNLOC
:
4083 case ISOCBINDING_F_PROCPOINTER
:
4085 tmp_sym
->attr
.proc
= PROC_MODULE
;
4087 /* Use the procedure's name as it is in the iso_c_binding module for
4088 setting the binding label in case the user renamed the symbol. */
4089 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
4090 c_interop_kinds_table
[s
].name
);
4091 tmp_sym
->attr
.is_iso_c
= 1;
4092 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4093 tmp_sym
->attr
.subroutine
= 1;
4096 /* TODO! This needs to be finished more for the expr of the
4097 function or something!
4098 This may not need to be here, because trying to do c_loc
4100 if (s
== ISOCBINDING_ASSOCIATED
)
4102 tmp_sym
->attr
.function
= 1;
4103 tmp_sym
->ts
.type
= BT_LOGICAL
;
4104 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4105 tmp_sym
->result
= tmp_sym
;
4109 /* Here, we're taking the simple approach. We're defining
4110 c_loc as an external identifier so the compiler will put
4111 what we expect on the stack for the address we want the
4113 tmp_sym
->ts
.type
= BT_DERIVED
;
4114 if (s
== ISOCBINDING_LOC
)
4115 tmp_sym
->ts
.derived
=
4116 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4118 tmp_sym
->ts
.derived
=
4119 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4121 if (tmp_sym
->ts
.derived
== NULL
)
4123 /* Create the necessary derived type so we can continue
4124 processing the file. */
4125 generate_isocbinding_symbol
4126 (mod_name
, s
== ISOCBINDING_FUNLOC
4127 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4128 (const char *)(s
== ISOCBINDING_FUNLOC
4129 ? "_gfortran_iso_c_binding_c_funptr"
4130 : "_gfortran_iso_c_binding_c_ptr"));
4131 tmp_sym
->ts
.derived
=
4132 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4133 ? ISOCBINDING_FUNPTR
4137 /* The function result is itself (no result clause). */
4138 tmp_sym
->result
= tmp_sym
;
4139 tmp_sym
->attr
.external
= 1;
4140 tmp_sym
->attr
.use_assoc
= 0;
4141 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4142 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4146 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4147 tmp_sym
->attr
.contained
= 0;
4149 /* Try using this builder routine, with the new and old symbols
4150 both being the generic iso_c proc sym being created. This
4151 will create the formal args (and the new namespace for them).
4152 Don't build an arg list for c_loc because we're going to treat
4153 c_loc as an external procedure. */
4154 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4155 /* The 1 says to add any optional args, if applicable. */
4156 build_formal_args (tmp_sym
, tmp_sym
, 1);
4158 /* Set this after setting up the symbol, to prevent error messages. */
4159 tmp_sym
->attr
.use_assoc
= 1;
4161 /* This symbol will not be referenced directly. It will be
4162 resolved to the implementation for the given f90 kind. */
4163 tmp_sym
->attr
.referenced
= 0;
4173 /* Creates a new symbol based off of an old iso_c symbol, with a new
4174 binding label. This function can be used to create a new,
4175 resolved, version of a procedure symbol for c_f_pointer or
4176 c_f_procpointer that is based on the generic symbols. A new
4177 parameter list is created for the new symbol using
4178 build_formal_args(). The add_optional_flag specifies whether the
4179 to add the optional SHAPE argument. The new symbol is
4183 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4184 char *new_binding_label
, int add_optional_arg
)
4186 gfc_symtree
*new_symtree
= NULL
;
4188 /* See if we have a symbol by that name already available, looking
4189 through any parent namespaces. */
4190 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4191 if (new_symtree
!= NULL
)
4192 /* Return the existing symbol. */
4193 return new_symtree
->n
.sym
;
4195 /* Create the symtree/symbol, with attempted host association. */
4196 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4197 if (new_symtree
== NULL
)
4198 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4199 "symtree for '%s'", new_name
);
4201 /* Now fill in the fields of the resolved symbol with the old sym. */
4202 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4203 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4204 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4205 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4206 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4207 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4208 /* Build the formal arg list. */
4209 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4211 gfc_commit_symbol (new_symtree
->n
.sym
);
4213 return new_symtree
->n
.sym
;