1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors
[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
41 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
42 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
43 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
47 const mstring procedures
[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
50 minit ("MODULE-PROC", PROC_MODULE
),
51 minit ("INTERNAL-PROC", PROC_INTERNAL
),
52 minit ("DUMMY-PROC", PROC_DUMMY
),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
59 const mstring intents
[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
62 minit ("IN", INTENT_IN
),
63 minit ("OUT", INTENT_OUT
),
64 minit ("INOUT", INTENT_INOUT
),
68 const mstring access_types
[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
71 minit ("PUBLIC", ACCESS_PUBLIC
),
72 minit ("PRIVATE", ACCESS_PRIVATE
),
76 const mstring ifsrc_types
[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN
),
79 minit ("DECL", IFSRC_DECL
),
80 minit ("BODY", IFSRC_IFBODY
)
83 const mstring save_status
[] =
85 minit ("UNKNOWN", SAVE_NONE
),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order
= 1;
96 gfc_namespace
*gfc_current_ns
;
97 gfc_namespace
*gfc_global_ns_list
;
99 gfc_gsymbol
*gfc_gsym_root
= NULL
;
101 static gfc_symbol
*changed_syms
= NULL
;
103 gfc_dt_list
*gfc_derived_types
;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc
*proc
;
111 struct tentative_tbp
*next
;
115 static tentative_tbp
*tentative_tbp_list
= NULL
;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag
[GFC_LETTERS
];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns
->seen_implicit_none
)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns
->seen_implicit_none
= 1;
141 for (i
= 0; i
< GFC_LETTERS
; i
++)
143 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
144 gfc_current_ns
->set_flag
[i
] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i
= 0; i
< GFC_LETTERS
; i
++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1
, int c2
)
171 for (i
= c1
; i
<= c2
; i
++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec
*ts
)
195 if (gfc_current_ns
->seen_implicit_none
)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i
= 0; i
< GFC_LETTERS
; i
++)
205 if (gfc_current_ns
->set_flag
[i
])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns
->default_type
[i
] = *ts
;
213 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
214 gfc_current_ns
->set_flag
[i
] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
230 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter
< 'a' || letter
> 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name
);
241 return &ns
->default_type
[letter
- 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
254 if (sym
->ts
.type
!= BT_UNKNOWN
)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts
= gfc_get_default_type (sym
->name
, ns
);
259 if (ts
->type
== BT_UNKNOWN
)
261 if (error_flag
&& !sym
->attr
.untyped
)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym
->name
, &sym
->declared_at
);
265 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
272 sym
->attr
.implicit_type
= 1;
274 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
275 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
277 if (sym
->attr
.is_bind_c
== 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym
->name
, &sym
->declared_at
);
282 sym
->ts
.f90_type
= sym
->ts
.type
;
285 if (sym
->attr
.dummy
!= 0)
287 if (sym
->ns
->proc_name
!= NULL
288 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
289 || sym
->ns
->proc_name
->attr
.function
!= 0)
290 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym
->name
,
297 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
298 &(sym
->ns
->proc_name
->declared_at
));
299 sym
->ts
.f90_type
= sym
->ts
.type
;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace
*ns
)
314 gfc_symbol
*proc
= ns
->proc_name
;
316 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
319 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
321 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
324 if (proc
->result
!= proc
)
326 proc
->ts
= proc
->result
->ts
;
327 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
328 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
329 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
330 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
333 else if (!proc
->result
->attr
.proc_pointer
)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc
->result
->name
, &proc
->result
->declared_at
);
337 proc
->result
->attr
.untyped
= 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
361 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
362 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
363 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
364 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
365 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
366 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
367 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
368 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
369 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
370 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
371 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
372 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
373 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
374 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
375 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
376 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC";
377 static const char *threadprivate
= "THREADPRIVATE";
383 where
= &gfc_current_locus
;
385 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
389 standard
= GFC_STD_F2003
;
393 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
396 a2
= attr
->allocatable
? allocatable
: pointer
;
397 standard
= GFC_STD_F2003
;
401 /* Check for attributes not allowed in a BLOCK DATA. */
402 if (gfc_current_state () == COMP_BLOCK_DATA
)
406 if (attr
->in_namelist
)
408 if (attr
->allocatable
)
414 if (attr
->access
== ACCESS_PRIVATE
)
416 if (attr
->access
== ACCESS_PUBLIC
)
418 if (attr
->intent
!= INTENT_UNKNOWN
)
424 ("%s attribute not allowed in BLOCK DATA program unit at %L",
430 if (attr
->save
== SAVE_EXPLICIT
)
433 conf (in_common
, save
);
436 switch (attr
->flavor
)
444 a1
= gfc_code2string (flavors
, attr
->flavor
);
448 gfc_error ("Namelist group name at %L cannot have the "
449 "SAVE attribute", where
);
453 /* Conflicts between SAVE and PROCEDURE will be checked at
454 resolution stage, see "resolve_fl_procedure". */
462 conf (dummy
, intrinsic
);
463 conf (dummy
, threadprivate
);
464 conf (pointer
, target
);
465 conf (pointer
, intrinsic
);
466 conf (pointer
, elemental
);
467 conf (allocatable
, elemental
);
469 conf (target
, external
);
470 conf (target
, intrinsic
);
472 if (!attr
->if_source
)
473 conf (external
, dimension
); /* See Fortran 95's R504. */
475 conf (external
, intrinsic
);
476 conf (entry
, intrinsic
);
478 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
479 conf (external
, subroutine
);
481 if (attr
->proc_pointer
&& gfc_notify_std (GFC_STD_F2003
,
482 "Fortran 2003: Procedure pointer at %C") == FAILURE
)
485 conf (allocatable
, pointer
);
486 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
487 conf_std (allocatable
, function
, GFC_STD_F2003
);
488 conf_std (allocatable
, result
, GFC_STD_F2003
);
489 conf (elemental
, recursive
);
491 conf (in_common
, dummy
);
492 conf (in_common
, allocatable
);
493 conf (in_common
, codimension
);
494 conf (in_common
, result
);
496 conf (in_equivalence
, use_assoc
);
497 conf (in_equivalence
, codimension
);
498 conf (in_equivalence
, dummy
);
499 conf (in_equivalence
, target
);
500 conf (in_equivalence
, pointer
);
501 conf (in_equivalence
, function
);
502 conf (in_equivalence
, result
);
503 conf (in_equivalence
, entry
);
504 conf (in_equivalence
, allocatable
);
505 conf (in_equivalence
, threadprivate
);
507 conf (dummy
, result
);
508 conf (entry
, result
);
509 conf (generic
, result
);
511 conf (function
, subroutine
);
513 if (!function
&& !subroutine
)
514 conf (is_bind_c
, dummy
);
516 conf (is_bind_c
, cray_pointer
);
517 conf (is_bind_c
, cray_pointee
);
518 conf (is_bind_c
, codimension
);
519 conf (is_bind_c
, allocatable
);
520 conf (is_bind_c
, elemental
);
522 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
523 Parameter conflict caught below. Also, value cannot be specified
524 for a dummy procedure. */
526 /* Cray pointer/pointee conflicts. */
527 conf (cray_pointer
, cray_pointee
);
528 conf (cray_pointer
, dimension
);
529 conf (cray_pointer
, codimension
);
530 conf (cray_pointer
, contiguous
);
531 conf (cray_pointer
, pointer
);
532 conf (cray_pointer
, target
);
533 conf (cray_pointer
, allocatable
);
534 conf (cray_pointer
, external
);
535 conf (cray_pointer
, intrinsic
);
536 conf (cray_pointer
, in_namelist
);
537 conf (cray_pointer
, function
);
538 conf (cray_pointer
, subroutine
);
539 conf (cray_pointer
, entry
);
541 conf (cray_pointee
, allocatable
);
542 conf (cray_pointer
, contiguous
);
543 conf (cray_pointer
, codimension
);
544 conf (cray_pointee
, intent
);
545 conf (cray_pointee
, optional
);
546 conf (cray_pointee
, dummy
);
547 conf (cray_pointee
, target
);
548 conf (cray_pointee
, intrinsic
);
549 conf (cray_pointee
, pointer
);
550 conf (cray_pointee
, entry
);
551 conf (cray_pointee
, in_common
);
552 conf (cray_pointee
, in_equivalence
);
553 conf (cray_pointee
, threadprivate
);
556 conf (data
, function
);
558 conf (data
, allocatable
);
560 conf (value
, pointer
)
561 conf (value
, allocatable
)
562 conf (value
, subroutine
)
563 conf (value
, function
)
564 conf (value
, volatile_
)
565 conf (value
, dimension
)
566 conf (value
, codimension
)
567 conf (value
, external
)
569 conf (codimension
, result
)
572 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
575 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
579 conf (is_protected
, intrinsic
)
580 conf (is_protected
, in_common
)
582 conf (asynchronous
, intrinsic
)
583 conf (asynchronous
, external
)
585 conf (volatile_
, intrinsic
)
586 conf (volatile_
, external
)
588 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
595 conf (procedure
, allocatable
)
596 conf (procedure
, dimension
)
597 conf (procedure
, codimension
)
598 conf (procedure
, intrinsic
)
599 conf (procedure
, target
)
600 conf (procedure
, value
)
601 conf (procedure
, volatile_
)
602 conf (procedure
, asynchronous
)
603 conf (procedure
, entry
)
605 a1
= gfc_code2string (flavors
, attr
->flavor
);
607 if (attr
->in_namelist
608 && attr
->flavor
!= FL_VARIABLE
609 && attr
->flavor
!= FL_PROCEDURE
610 && attr
->flavor
!= FL_UNKNOWN
)
616 switch (attr
->flavor
)
626 conf2 (asynchronous
);
629 conf2 (is_protected
);
639 conf2 (threadprivate
);
641 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
643 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
644 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
651 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
665 /* Conflicts with INTENT, SAVE and RESULT will be checked
666 at resolution stage, see "resolve_fl_procedure". */
668 if (attr
->subroutine
)
674 conf2 (asynchronous
);
679 if (!attr
->proc_pointer
)
680 conf2 (threadprivate
);
683 if (!attr
->proc_pointer
)
688 case PROC_ST_FUNCTION
:
699 conf2 (threadprivate
);
719 conf2 (threadprivate
);
722 if (attr
->intent
!= INTENT_UNKNOWN
)
739 conf2 (is_protected
);
745 conf2 (asynchronous
);
746 conf2 (threadprivate
);
762 gfc_error ("%s attribute conflicts with %s attribute at %L",
765 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
766 a1
, a2
, name
, where
);
773 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
774 "with %s attribute at %L", a1
, a2
,
779 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
780 "with %s attribute in '%s' at %L",
781 a1
, a2
, name
, where
);
790 /* Mark a symbol as referenced. */
793 gfc_set_sym_referenced (gfc_symbol
*sym
)
796 if (sym
->attr
.referenced
)
799 sym
->attr
.referenced
= 1;
801 /* Remember which order dummy variables are accessed in. */
803 sym
->dummy_order
= next_dummy_order
++;
807 /* Common subroutine called by attribute changing subroutines in order
808 to prevent them from changing a symbol that has been
809 use-associated. Returns zero if it is OK to change the symbol,
813 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
816 if (attr
->use_assoc
== 0)
820 where
= &gfc_current_locus
;
823 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
826 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
833 /* Generate an error because of a duplicate attribute. */
836 duplicate_attr (const char *attr
, locus
*where
)
840 where
= &gfc_current_locus
;
842 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
847 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
848 locus
*where ATTRIBUTE_UNUSED
)
850 attr
->ext_attr
|= 1 << ext_attr
;
855 /* Called from decl.c (attr_decl1) to check attributes, when declared
859 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
861 if (check_used (attr
, NULL
, where
))
864 return check_conflict (attr
, NULL
, where
);
869 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
872 if (check_used (attr
, NULL
, where
))
875 if (attr
->allocatable
)
877 duplicate_attr ("ALLOCATABLE", where
);
881 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
882 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
884 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
889 attr
->allocatable
= 1;
890 return check_conflict (attr
, NULL
, where
);
895 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
898 if (check_used (attr
, name
, where
))
901 if (attr
->codimension
)
903 duplicate_attr ("CODIMENSION", where
);
907 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
908 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
910 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
911 "at %L", name
, where
);
915 attr
->codimension
= 1;
916 return check_conflict (attr
, name
, where
);
921 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
924 if (check_used (attr
, name
, where
))
929 duplicate_attr ("DIMENSION", where
);
933 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
934 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
936 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
937 "at %L", name
, where
);
942 return check_conflict (attr
, name
, where
);
947 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
950 if (check_used (attr
, name
, where
))
953 attr
->contiguous
= 1;
954 return check_conflict (attr
, name
, where
);
959 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
962 if (check_used (attr
, NULL
, where
))
967 duplicate_attr ("EXTERNAL", where
);
971 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
974 attr
->proc_pointer
= 1;
979 return check_conflict (attr
, NULL
, where
);
984 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
987 if (check_used (attr
, NULL
, where
))
992 duplicate_attr ("INTRINSIC", where
);
998 return check_conflict (attr
, NULL
, where
);
1003 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1006 if (check_used (attr
, NULL
, where
))
1011 duplicate_attr ("OPTIONAL", where
);
1016 return check_conflict (attr
, NULL
, where
);
1021 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1024 if (check_used (attr
, NULL
, where
))
1027 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1028 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1030 duplicate_attr ("POINTER", where
);
1034 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1035 || (attr
->if_source
== IFSRC_IFBODY
1036 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1037 attr
->proc_pointer
= 1;
1041 return check_conflict (attr
, NULL
, where
);
1046 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1049 if (check_used (attr
, NULL
, where
))
1052 attr
->cray_pointer
= 1;
1053 return check_conflict (attr
, NULL
, where
);
1058 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1061 if (check_used (attr
, NULL
, where
))
1064 if (attr
->cray_pointee
)
1066 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1067 " statements", where
);
1071 attr
->cray_pointee
= 1;
1072 return check_conflict (attr
, NULL
, where
);
1077 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1079 if (check_used (attr
, name
, where
))
1082 if (attr
->is_protected
)
1084 if (gfc_notify_std (GFC_STD_LEGACY
,
1085 "Duplicate PROTECTED attribute specified at %L",
1091 attr
->is_protected
= 1;
1092 return check_conflict (attr
, name
, where
);
1097 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1100 if (check_used (attr
, name
, where
))
1104 return check_conflict (attr
, name
, where
);
1109 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1113 if (check_used (attr
, name
, where
))
1116 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1119 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1124 if (s
== SAVE_EXPLICIT
&& gfc_implicit_pure (NULL
))
1125 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1127 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1129 if (gfc_notify_std (GFC_STD_LEGACY
,
1130 "Duplicate SAVE attribute specified at %L",
1137 return check_conflict (attr
, name
, where
);
1142 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1145 if (check_used (attr
, name
, where
))
1150 if (gfc_notify_std (GFC_STD_LEGACY
,
1151 "Duplicate VALUE attribute specified at %L",
1158 return check_conflict (attr
, name
, where
);
1163 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1165 /* No check_used needed as 11.2.1 of the F2003 standard allows
1166 that the local identifier made accessible by a use statement can be
1167 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1169 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1170 if (gfc_notify_std (GFC_STD_LEGACY
,
1171 "Duplicate VOLATILE attribute specified at %L", where
)
1175 attr
->volatile_
= 1;
1176 attr
->volatile_ns
= gfc_current_ns
;
1177 return check_conflict (attr
, name
, where
);
1182 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1184 /* No check_used needed as 11.2.1 of the F2003 standard allows
1185 that the local identifier made accessible by a use statement can be
1186 given a ASYNCHRONOUS attribute. */
1188 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1189 if (gfc_notify_std (GFC_STD_LEGACY
,
1190 "Duplicate ASYNCHRONOUS attribute specified at %L",
1194 attr
->asynchronous
= 1;
1195 attr
->asynchronous_ns
= gfc_current_ns
;
1196 return check_conflict (attr
, name
, where
);
1201 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1204 if (check_used (attr
, name
, where
))
1207 if (attr
->threadprivate
)
1209 duplicate_attr ("THREADPRIVATE", where
);
1213 attr
->threadprivate
= 1;
1214 return check_conflict (attr
, name
, where
);
1219 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1222 if (check_used (attr
, NULL
, where
))
1227 duplicate_attr ("TARGET", where
);
1232 return check_conflict (attr
, NULL
, where
);
1237 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1240 if (check_used (attr
, name
, where
))
1243 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1245 return check_conflict (attr
, name
, where
);
1250 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1253 if (check_used (attr
, name
, where
))
1256 /* Duplicate attribute already checked for. */
1257 attr
->in_common
= 1;
1258 return check_conflict (attr
, name
, where
);
1263 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1266 /* Duplicate attribute already checked for. */
1267 attr
->in_equivalence
= 1;
1268 if (check_conflict (attr
, name
, where
) == FAILURE
)
1271 if (attr
->flavor
== FL_VARIABLE
)
1274 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1279 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1282 if (check_used (attr
, name
, where
))
1286 return check_conflict (attr
, name
, where
);
1291 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1294 attr
->in_namelist
= 1;
1295 return check_conflict (attr
, name
, where
);
1300 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1303 if (check_used (attr
, name
, where
))
1307 return check_conflict (attr
, name
, where
);
1312 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1315 if (check_used (attr
, NULL
, where
))
1318 if (attr
->elemental
)
1320 duplicate_attr ("ELEMENTAL", where
);
1324 attr
->elemental
= 1;
1325 return check_conflict (attr
, NULL
, where
);
1330 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1333 if (check_used (attr
, NULL
, where
))
1338 duplicate_attr ("PURE", where
);
1343 return check_conflict (attr
, NULL
, where
);
1348 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1351 if (check_used (attr
, NULL
, where
))
1354 if (attr
->recursive
)
1356 duplicate_attr ("RECURSIVE", where
);
1360 attr
->recursive
= 1;
1361 return check_conflict (attr
, NULL
, where
);
1366 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1369 if (check_used (attr
, name
, where
))
1374 duplicate_attr ("ENTRY", where
);
1379 return check_conflict (attr
, name
, where
);
1384 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1387 if (attr
->flavor
!= FL_PROCEDURE
1388 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1392 return check_conflict (attr
, name
, where
);
1397 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1400 if (attr
->flavor
!= FL_PROCEDURE
1401 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1404 attr
->subroutine
= 1;
1405 return check_conflict (attr
, name
, where
);
1410 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1413 if (attr
->flavor
!= FL_PROCEDURE
1414 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1418 return check_conflict (attr
, name
, where
);
1423 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1426 if (check_used (attr
, NULL
, where
))
1429 if (attr
->flavor
!= FL_PROCEDURE
1430 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1433 if (attr
->procedure
)
1435 duplicate_attr ("PROCEDURE", where
);
1439 attr
->procedure
= 1;
1441 return check_conflict (attr
, NULL
, where
);
1446 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1450 duplicate_attr ("ABSTRACT", where
);
1459 /* Flavors are special because some flavors are not what Fortran
1460 considers attributes and can be reaffirmed multiple times. */
1463 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1467 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1468 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1469 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1472 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1475 if (attr
->flavor
!= FL_UNKNOWN
)
1478 where
= &gfc_current_locus
;
1481 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1482 gfc_code2string (flavors
, attr
->flavor
), name
,
1483 gfc_code2string (flavors
, f
), where
);
1485 gfc_error ("%s attribute conflicts with %s attribute at %L",
1486 gfc_code2string (flavors
, attr
->flavor
),
1487 gfc_code2string (flavors
, f
), where
);
1494 return check_conflict (attr
, name
, where
);
1499 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1500 const char *name
, locus
*where
)
1503 if (check_used (attr
, name
, where
))
1506 if (attr
->flavor
!= FL_PROCEDURE
1507 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1511 where
= &gfc_current_locus
;
1513 if (attr
->proc
!= PROC_UNKNOWN
)
1515 gfc_error ("%s procedure at %L is already declared as %s procedure",
1516 gfc_code2string (procedures
, t
), where
,
1517 gfc_code2string (procedures
, attr
->proc
));
1524 /* Statement functions are always scalar and functions. */
1525 if (t
== PROC_ST_FUNCTION
1526 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1527 || attr
->dimension
))
1530 return check_conflict (attr
, name
, where
);
1535 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1538 if (check_used (attr
, NULL
, where
))
1541 if (attr
->intent
== INTENT_UNKNOWN
)
1543 attr
->intent
= intent
;
1544 return check_conflict (attr
, NULL
, where
);
1548 where
= &gfc_current_locus
;
1550 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1551 gfc_intent_string (attr
->intent
),
1552 gfc_intent_string (intent
), where
);
1558 /* No checks for use-association in public and private statements. */
1561 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1562 const char *name
, locus
*where
)
1565 if (attr
->access
== ACCESS_UNKNOWN
1566 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1568 attr
->access
= access
;
1569 return check_conflict (attr
, name
, where
);
1573 where
= &gfc_current_locus
;
1574 gfc_error ("ACCESS specification at %L was already specified", where
);
1580 /* Set the is_bind_c field for the given symbol_attribute. */
1583 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1584 int is_proc_lang_bind_spec
)
1587 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1588 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1589 "variables or common blocks", where
);
1590 else if (attr
->is_bind_c
)
1591 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1593 attr
->is_bind_c
= 1;
1596 where
= &gfc_current_locus
;
1598 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1602 return check_conflict (attr
, name
, where
);
1606 /* Set the extension field for the given symbol_attribute. */
1609 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1612 where
= &gfc_current_locus
;
1614 if (attr
->extension
)
1615 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1617 attr
->extension
= 1;
1619 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1628 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1629 gfc_formal_arglist
* formal
, locus
*where
)
1632 if (check_used (&sym
->attr
, sym
->name
, where
))
1636 where
= &gfc_current_locus
;
1638 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1639 && sym
->attr
.if_source
!= IFSRC_DECL
)
1641 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1646 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1648 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1649 "body", sym
->name
, where
);
1653 sym
->formal
= formal
;
1654 sym
->attr
.if_source
= source
;
1660 /* Add a type to a symbol. */
1663 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1669 where
= &gfc_current_locus
;
1672 type
= sym
->result
->ts
.type
;
1674 type
= sym
->ts
.type
;
1676 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1677 type
= sym
->ns
->proc_name
->ts
.type
;
1679 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1681 if (sym
->attr
.use_assoc
)
1682 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1683 "use-associated at %L", sym
->name
, where
, sym
->module
,
1686 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1687 where
, gfc_basic_typename (type
));
1691 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1693 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1694 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1698 flavor
= sym
->attr
.flavor
;
1700 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1701 || flavor
== FL_LABEL
1702 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1703 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1705 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1714 /* Clears all attributes. */
1717 gfc_clear_attr (symbol_attribute
*attr
)
1719 memset (attr
, 0, sizeof (symbol_attribute
));
1723 /* Check for missing attributes in the new symbol. Currently does
1724 nothing, but it's not clear that it is unnecessary yet. */
1727 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1728 locus
*where ATTRIBUTE_UNUSED
)
1735 /* Copy an attribute to a symbol attribute, bit by bit. Some
1736 attributes have a lot of side-effects but cannot be present given
1737 where we are called from, so we ignore some bits. */
1740 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1742 int is_proc_lang_bind_spec
;
1744 /* In line with the other attributes, we only add bits but do not remove
1745 them; cf. also PR 41034. */
1746 dest
->ext_attr
|= src
->ext_attr
;
1748 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1751 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1753 if (src
->codimension
&& gfc_add_codimension (dest
, NULL
, where
) == FAILURE
)
1755 if (src
->contiguous
&& gfc_add_contiguous (dest
, NULL
, where
) == FAILURE
)
1757 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1759 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1761 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1763 if (src
->save
&& gfc_add_save (dest
, src
->save
, NULL
, where
) == FAILURE
)
1765 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1767 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1769 if (src
->asynchronous
&& gfc_add_asynchronous (dest
, NULL
, where
) == FAILURE
)
1771 if (src
->threadprivate
1772 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1774 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1776 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1778 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1783 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1786 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1789 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1791 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1793 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1796 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1798 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1800 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1802 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1805 if (src
->flavor
!= FL_UNKNOWN
1806 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1809 if (src
->intent
!= INTENT_UNKNOWN
1810 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1813 if (src
->access
!= ACCESS_UNKNOWN
1814 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1817 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1820 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1822 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1825 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1827 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1831 if (src
->is_c_interop
)
1832 dest
->is_c_interop
= 1;
1836 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1838 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1840 if (src
->proc_pointer
)
1841 dest
->proc_pointer
= 1;
1850 /************** Component name management ************/
1852 /* Component names of a derived type form their own little namespaces
1853 that are separate from all other spaces. The space is composed of
1854 a singly linked list of gfc_component structures whose head is
1855 located in the parent symbol. */
1858 /* Add a component name to a symbol. The call fails if the name is
1859 already present. On success, the component pointer is modified to
1860 point to the additional component structure. */
1863 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1864 gfc_component
**component
)
1866 gfc_component
*p
, *tail
;
1870 for (p
= sym
->components
; p
; p
= p
->next
)
1872 if (strcmp (p
->name
, name
) == 0)
1874 gfc_error ("Component '%s' at %C already declared at %L",
1882 if (sym
->attr
.extension
1883 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1885 gfc_error ("Component '%s' at %C already in the parent type "
1886 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1890 /* Allocate a new component. */
1891 p
= gfc_get_component ();
1894 sym
->components
= p
;
1898 p
->name
= gfc_get_string (name
);
1899 p
->loc
= gfc_current_locus
;
1900 p
->ts
.type
= BT_UNKNOWN
;
1907 /* Recursive function to switch derived types of all symbol in a
1911 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1919 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1920 sym
->ts
.u
.derived
= to
;
1922 switch_types (st
->left
, from
, to
);
1923 switch_types (st
->right
, from
, to
);
1927 /* This subroutine is called when a derived type is used in order to
1928 make the final determination about which version to use. The
1929 standard requires that a type be defined before it is 'used', but
1930 such types can appear in IMPLICIT statements before the actual
1931 definition. 'Using' in this context means declaring a variable to
1932 be that type or using the type constructor.
1934 If a type is used and the components haven't been defined, then we
1935 have to have a derived type in a parent unit. We find the node in
1936 the other namespace and point the symtree node in this namespace to
1937 that node. Further reference to this name point to the correct
1938 node. If we can't find the node in a parent namespace, then we have
1941 This subroutine takes a pointer to a symbol node and returns a
1942 pointer to the translated node or NULL for an error. Usually there
1943 is no translation and we return the node we were passed. */
1946 gfc_use_derived (gfc_symbol
*sym
)
1956 if (sym
->attr
.generic
)
1957 sym
= gfc_find_dt_in_generic (sym
);
1959 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1960 return sym
; /* Already defined. */
1962 if (sym
->ns
->parent
== NULL
)
1965 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1967 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1971 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1974 /* Get rid of symbol sym, translating all references to s. */
1975 for (i
= 0; i
< GFC_LETTERS
; i
++)
1977 t
= &sym
->ns
->default_type
[i
];
1978 if (t
->u
.derived
== sym
)
1982 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1987 /* Unlink from list of modified symbols. */
1988 gfc_commit_symbol (sym
);
1990 switch_types (sym
->ns
->sym_root
, sym
, s
);
1992 /* TODO: Also have to replace sym -> s in other lists like
1993 namelists, common lists and interface lists. */
1994 gfc_free_symbol (sym
);
1999 gfc_error ("Derived type '%s' at %C is being used before it is defined",
2005 /* Given a derived type node and a component name, try to locate the
2006 component structure. Returns the NULL pointer if the component is
2007 not found or the components are private. If noaccess is set, no access
2011 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2012 bool noaccess
, bool silent
)
2016 if (name
== NULL
|| sym
== NULL
)
2019 sym
= gfc_use_derived (sym
);
2024 for (p
= sym
->components
; p
; p
= p
->next
)
2025 if (strcmp (p
->name
, name
) == 0)
2028 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2030 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2031 if (p
->attr
.access
== ACCESS_PRIVATE
||
2032 (p
->attr
.access
!= ACCESS_PUBLIC
2033 && sym
->component_access
== ACCESS_PRIVATE
2034 && !is_parent_comp
))
2037 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2044 && sym
->attr
.extension
2045 && sym
->components
->ts
.type
== BT_DERIVED
)
2047 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2049 /* Do not overwrite the error. */
2054 if (p
== NULL
&& !silent
)
2055 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2062 /* Given a symbol, free all of the component structures and everything
2066 free_components (gfc_component
*p
)
2074 gfc_free_array_spec (p
->as
);
2075 gfc_free_expr (p
->initializer
);
2077 gfc_free_formal_arglist (p
->formal
);
2078 gfc_free_namespace (p
->formal_ns
);
2085 /******************** Statement label management ********************/
2087 /* Comparison function for statement labels, used for managing the
2091 compare_st_labels (void *a1
, void *b1
)
2093 int a
= ((gfc_st_label
*) a1
)->value
;
2094 int b
= ((gfc_st_label
*) b1
)->value
;
2100 /* Free a single gfc_st_label structure, making sure the tree is not
2101 messed up. This function is called only when some parse error
2105 gfc_free_st_label (gfc_st_label
*label
)
2111 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2113 if (label
->format
!= NULL
)
2114 gfc_free_expr (label
->format
);
2120 /* Free a whole tree of gfc_st_label structures. */
2123 free_st_labels (gfc_st_label
*label
)
2129 free_st_labels (label
->left
);
2130 free_st_labels (label
->right
);
2132 if (label
->format
!= NULL
)
2133 gfc_free_expr (label
->format
);
2138 /* Given a label number, search for and return a pointer to the label
2139 structure, creating it if it does not exist. */
2142 gfc_get_st_label (int labelno
)
2147 if (gfc_current_state () == COMP_DERIVED
)
2148 ns
= gfc_current_block ()->f2k_derived
;
2151 /* Find the namespace of the scoping unit:
2152 If we're in a BLOCK construct, jump to the parent namespace. */
2153 ns
= gfc_current_ns
;
2154 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2158 /* First see if the label is already in this namespace. */
2162 if (lp
->value
== labelno
)
2165 if (lp
->value
< labelno
)
2171 lp
= XCNEW (gfc_st_label
);
2173 lp
->value
= labelno
;
2174 lp
->defined
= ST_LABEL_UNKNOWN
;
2175 lp
->referenced
= ST_LABEL_UNKNOWN
;
2177 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2183 /* Called when a statement with a statement label is about to be
2184 accepted. We add the label to the list of the current namespace,
2185 making sure it hasn't been defined previously and referenced
2189 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2193 labelno
= lp
->value
;
2195 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2196 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2197 &lp
->where
, label_locus
);
2200 lp
->where
= *label_locus
;
2204 case ST_LABEL_FORMAT
:
2205 if (lp
->referenced
== ST_LABEL_TARGET
)
2206 gfc_error ("Label %d at %C already referenced as branch target",
2209 lp
->defined
= ST_LABEL_FORMAT
;
2213 case ST_LABEL_TARGET
:
2214 if (lp
->referenced
== ST_LABEL_FORMAT
)
2215 gfc_error ("Label %d at %C already referenced as a format label",
2218 lp
->defined
= ST_LABEL_TARGET
;
2223 lp
->defined
= ST_LABEL_BAD_TARGET
;
2224 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2230 /* Reference a label. Given a label and its type, see if that
2231 reference is consistent with what is known about that label,
2232 updating the unknown state. Returns FAILURE if something goes
2236 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2238 gfc_sl_type label_type
;
2245 labelno
= lp
->value
;
2247 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2248 label_type
= lp
->defined
;
2251 label_type
= lp
->referenced
;
2252 lp
->where
= gfc_current_locus
;
2255 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2257 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2262 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2263 && type
== ST_LABEL_FORMAT
)
2265 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2270 lp
->referenced
= type
;
2278 /************** Symbol table management subroutines ****************/
2280 /* Basic details: Fortran 95 requires a potentially unlimited number
2281 of distinct namespaces when compiling a program unit. This case
2282 occurs during a compilation of internal subprograms because all of
2283 the internal subprograms must be read before we can start
2284 generating code for the host.
2286 Given the tricky nature of the Fortran grammar, we must be able to
2287 undo changes made to a symbol table if the current interpretation
2288 of a statement is found to be incorrect. Whenever a symbol is
2289 looked up, we make a copy of it and link to it. All of these
2290 symbols are kept in a singly linked list so that we can commit or
2291 undo the changes at a later time.
2293 A symtree may point to a symbol node outside of its namespace. In
2294 this case, that symbol has been used as a host associated variable
2295 at some previous time. */
2297 /* Allocate a new namespace structure. Copies the implicit types from
2298 PARENT if PARENT_TYPES is set. */
2301 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2308 ns
= XCNEW (gfc_namespace
);
2309 ns
->sym_root
= NULL
;
2310 ns
->uop_root
= NULL
;
2311 ns
->tb_sym_root
= NULL
;
2312 ns
->finalizers
= NULL
;
2313 ns
->default_access
= ACCESS_UNKNOWN
;
2314 ns
->parent
= parent
;
2316 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2318 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2319 ns
->tb_op
[in
] = NULL
;
2322 /* Initialize default implicit types. */
2323 for (i
= 'a'; i
<= 'z'; i
++)
2325 ns
->set_flag
[i
- 'a'] = 0;
2326 ts
= &ns
->default_type
[i
- 'a'];
2328 if (parent_types
&& ns
->parent
!= NULL
)
2330 /* Copy parent settings. */
2331 *ts
= ns
->parent
->default_type
[i
- 'a'];
2335 if (gfc_option
.flag_implicit_none
!= 0)
2341 if ('i' <= i
&& i
<= 'n')
2343 ts
->type
= BT_INTEGER
;
2344 ts
->kind
= gfc_default_integer_kind
;
2349 ts
->kind
= gfc_default_real_kind
;
2359 /* Comparison function for symtree nodes. */
2362 compare_symtree (void *_st1
, void *_st2
)
2364 gfc_symtree
*st1
, *st2
;
2366 st1
= (gfc_symtree
*) _st1
;
2367 st2
= (gfc_symtree
*) _st2
;
2369 return strcmp (st1
->name
, st2
->name
);
2373 /* Allocate a new symtree node and associate it with the new symbol. */
2376 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2380 st
= XCNEW (gfc_symtree
);
2381 st
->name
= gfc_get_string (name
);
2383 gfc_insert_bbt (root
, st
, compare_symtree
);
2388 /* Delete a symbol from the tree. Does not free the symbol itself! */
2391 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2393 gfc_symtree st
, *st0
;
2395 st0
= gfc_find_symtree (*root
, name
);
2397 st
.name
= gfc_get_string (name
);
2398 gfc_delete_bbt (root
, &st
, compare_symtree
);
2404 /* Given a root symtree node and a name, try to find the symbol within
2405 the namespace. Returns NULL if the symbol is not found. */
2408 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2414 c
= strcmp (name
, st
->name
);
2418 st
= (c
< 0) ? st
->left
: st
->right
;
2425 /* Return a symtree node with a name that is guaranteed to be unique
2426 within the namespace and corresponds to an illegal fortran name. */
2429 gfc_get_unique_symtree (gfc_namespace
*ns
)
2431 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2432 static int serial
= 0;
2434 sprintf (name
, "@%d", serial
++);
2435 return gfc_new_symtree (&ns
->sym_root
, name
);
2439 /* Given a name find a user operator node, creating it if it doesn't
2440 exist. These are much simpler than symbols because they can't be
2441 ambiguous with one another. */
2444 gfc_get_uop (const char *name
)
2449 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2453 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2455 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2456 uop
->name
= gfc_get_string (name
);
2457 uop
->access
= ACCESS_UNKNOWN
;
2458 uop
->ns
= gfc_current_ns
;
2464 /* Given a name find the user operator node. Returns NULL if it does
2468 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2473 ns
= gfc_current_ns
;
2475 st
= gfc_find_symtree (ns
->uop_root
, name
);
2476 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2480 /* Remove a gfc_symbol structure and everything it points to. */
2483 gfc_free_symbol (gfc_symbol
*sym
)
2489 gfc_free_array_spec (sym
->as
);
2491 free_components (sym
->components
);
2493 gfc_free_expr (sym
->value
);
2495 gfc_free_namelist (sym
->namelist
);
2497 gfc_free_namespace (sym
->formal_ns
);
2499 if (!sym
->attr
.generic_copy
)
2500 gfc_free_interface (sym
->generic
);
2502 gfc_free_formal_arglist (sym
->formal
);
2504 gfc_free_namespace (sym
->f2k_derived
);
2510 /* Decrease the reference counter and free memory when we reach zero. */
2513 gfc_release_symbol (gfc_symbol
*sym
)
2518 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2)
2520 /* As formal_ns contains a reference to sym, delete formal_ns just
2521 before the deletion of sym. */
2522 gfc_namespace
*ns
= sym
->formal_ns
;
2523 sym
->formal_ns
= NULL
;
2524 gfc_free_namespace (ns
);
2531 gcc_assert (sym
->refs
== 0);
2532 gfc_free_symbol (sym
);
2536 /* Allocate and initialize a new symbol node. */
2539 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2543 p
= XCNEW (gfc_symbol
);
2545 gfc_clear_ts (&p
->ts
);
2546 gfc_clear_attr (&p
->attr
);
2549 p
->declared_at
= gfc_current_locus
;
2551 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2552 gfc_internal_error ("new_symbol(): Symbol name too long");
2554 p
->name
= gfc_get_string (name
);
2556 /* Make sure flags for symbol being C bound are clear initially. */
2557 p
->attr
.is_bind_c
= 0;
2558 p
->attr
.is_iso_c
= 0;
2560 /* Clear the ptrs we may need. */
2561 p
->common_block
= NULL
;
2562 p
->f2k_derived
= NULL
;
2569 /* Generate an error if a symbol is ambiguous. */
2572 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2575 if (st
->n
.sym
->module
)
2576 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2577 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2579 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2580 "from current program unit", name
, st
->n
.sym
->name
);
2584 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2585 selector on the stack. If yes, replace it by the corresponding temporary. */
2588 select_type_insert_tmp (gfc_symtree
**st
)
2590 gfc_select_type_stack
*stack
= select_type_stack
;
2591 for (; stack
; stack
= stack
->prev
)
2592 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2597 /* Look for a symtree in the current procedure -- that is, go up to
2598 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2601 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
2605 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
2609 if (!ns
->construct_entities
)
2618 /* Search for a symtree starting in the current namespace, resorting to
2619 any parent namespaces if requested by a nonzero parent_flag.
2620 Returns nonzero if the name is ambiguous. */
2623 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2624 gfc_symtree
**result
)
2629 ns
= gfc_current_ns
;
2633 st
= gfc_find_symtree (ns
->sym_root
, name
);
2636 select_type_insert_tmp (&st
);
2639 /* Ambiguous generic interfaces are permitted, as long
2640 as the specific interfaces are different. */
2641 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2643 ambiguous_symbol (name
, st
);
2662 /* Same, but returns the symbol instead. */
2665 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2666 gfc_symbol
**result
)
2671 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2676 *result
= st
->n
.sym
;
2682 /* Save symbol with the information necessary to back it out. */
2685 save_symbol_data (gfc_symbol
*sym
)
2688 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2691 sym
->old_symbol
= XCNEW (gfc_symbol
);
2692 *(sym
->old_symbol
) = *sym
;
2694 sym
->tlink
= changed_syms
;
2699 /* Given a name, find a symbol, or create it if it does not exist yet
2700 in the current namespace. If the symbol is found we make sure that
2703 The integer return code indicates
2705 1 The symbol name was ambiguous
2706 2 The name meant to be established was already host associated.
2708 So if the return value is nonzero, then an error was issued. */
2711 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2712 bool allow_subroutine
)
2717 /* This doesn't usually happen during resolution. */
2719 ns
= gfc_current_ns
;
2721 /* Try to find the symbol in ns. */
2722 st
= gfc_find_symtree (ns
->sym_root
, name
);
2726 /* If not there, create a new symbol. */
2727 p
= gfc_new_symbol (name
, ns
);
2729 /* Add to the list of tentative symbols. */
2730 p
->old_symbol
= NULL
;
2731 p
->tlink
= changed_syms
;
2736 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2743 /* Make sure the existing symbol is OK. Ambiguous
2744 generic interfaces are permitted, as long as the
2745 specific interfaces are different. */
2746 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2748 ambiguous_symbol (name
, st
);
2753 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2754 && !(allow_subroutine
&& p
->attr
.subroutine
)
2755 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2756 && (ns
->has_import_set
|| p
->attr
.imported
)))
2758 /* Symbol is from another namespace. */
2759 gfc_error ("Symbol '%s' at %C has already been host associated",
2766 /* Copy in case this symbol is changed. */
2767 save_symbol_data (p
);
2776 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2781 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2786 *result
= st
->n
.sym
;
2793 /* Subroutine that searches for a symbol, creating it if it doesn't
2794 exist, but tries to host-associate the symbol if possible. */
2797 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2802 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2806 save_symbol_data (st
->n
.sym
);
2811 if (gfc_current_ns
->parent
!= NULL
)
2813 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2824 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2829 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2834 i
= gfc_get_ha_sym_tree (name
, &st
);
2837 *result
= st
->n
.sym
;
2844 /* Undoes all the changes made to symbols in the current statement.
2845 This subroutine is made simpler due to the fact that attributes are
2846 never removed once added. */
2849 gfc_undo_symbols (void)
2851 gfc_symbol
*p
, *q
, *old
;
2852 tentative_tbp
*tbp
, *tbq
;
2854 for (p
= changed_syms
; p
; p
= q
)
2860 /* Symbol was new. */
2861 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
2863 /* If the symbol was added to any common block, it
2864 needs to be removed to stop the resolver looking
2865 for a (possibly) dead symbol. */
2867 if (p
->common_block
->head
== p
)
2868 p
->common_block
->head
= p
->common_next
;
2871 gfc_symbol
*cparent
, *csym
;
2873 cparent
= p
->common_block
->head
;
2874 csym
= cparent
->common_next
;
2879 csym
= csym
->common_next
;
2882 gcc_assert(cparent
->common_next
== p
);
2884 cparent
->common_next
= csym
->common_next
;
2888 /* The derived type is saved in the symtree with the first
2889 letter capitalized; the all lower-case version to the
2890 derived type contains its associated generic function. */
2891 if (p
->attr
.flavor
== FL_DERIVED
)
2892 gfc_delete_symtree (&p
->ns
->sym_root
, gfc_get_string ("%c%s",
2893 (char) TOUPPER ((unsigned char) p
->name
[0]),
2896 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2898 gfc_release_symbol (p
);
2902 /* Restore previous state of symbol. Just copy simple stuff. */
2904 old
= p
->old_symbol
;
2906 p
->ts
.type
= old
->ts
.type
;
2907 p
->ts
.kind
= old
->ts
.kind
;
2909 p
->attr
= old
->attr
;
2911 if (p
->value
!= old
->value
)
2913 gfc_free_expr (old
->value
);
2917 if (p
->as
!= old
->as
)
2920 gfc_free_array_spec (p
->as
);
2924 p
->generic
= old
->generic
;
2925 p
->component_access
= old
->component_access
;
2927 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2929 gfc_free_namelist (p
->namelist
);
2934 if (p
->namelist_tail
!= old
->namelist_tail
)
2936 gfc_free_namelist (old
->namelist_tail
);
2937 old
->namelist_tail
->next
= NULL
;
2941 p
->namelist_tail
= old
->namelist_tail
;
2943 if (p
->formal
!= old
->formal
)
2945 gfc_free_formal_arglist (p
->formal
);
2946 p
->formal
= old
->formal
;
2949 free (p
->old_symbol
);
2950 p
->old_symbol
= NULL
;
2954 changed_syms
= NULL
;
2956 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2959 /* Procedure is already marked `error' by default. */
2962 tentative_tbp_list
= NULL
;
2966 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2967 components of old_symbol that might need deallocation are the "allocatables"
2968 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2969 namelist_tail. In case these differ between old_symbol and sym, it's just
2970 because sym->namelist has gotten a few more items. */
2973 free_old_symbol (gfc_symbol
*sym
)
2976 if (sym
->old_symbol
== NULL
)
2979 if (sym
->old_symbol
->as
!= sym
->as
)
2980 gfc_free_array_spec (sym
->old_symbol
->as
);
2982 if (sym
->old_symbol
->value
!= sym
->value
)
2983 gfc_free_expr (sym
->old_symbol
->value
);
2985 if (sym
->old_symbol
->formal
!= sym
->formal
)
2986 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2988 free (sym
->old_symbol
);
2989 sym
->old_symbol
= NULL
;
2993 /* Makes the changes made in the current statement permanent-- gets
2994 rid of undo information. */
2997 gfc_commit_symbols (void)
3000 tentative_tbp
*tbp
, *tbq
;
3002 for (p
= changed_syms
; p
; p
= q
)
3008 free_old_symbol (p
);
3010 changed_syms
= NULL
;
3012 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
3015 tbp
->proc
->error
= 0;
3018 tentative_tbp_list
= NULL
;
3022 /* Makes the changes made in one symbol permanent -- gets rid of undo
3026 gfc_commit_symbol (gfc_symbol
*sym
)
3030 if (changed_syms
== sym
)
3031 changed_syms
= sym
->tlink
;
3034 for (p
= changed_syms
; p
; p
= p
->tlink
)
3035 if (p
->tlink
== sym
)
3037 p
->tlink
= sym
->tlink
;
3046 free_old_symbol (sym
);
3050 /* Recursively free trees containing type-bound procedures. */
3053 free_tb_tree (gfc_symtree
*t
)
3058 free_tb_tree (t
->left
);
3059 free_tb_tree (t
->right
);
3061 /* TODO: Free type-bound procedure structs themselves; probably needs some
3062 sort of ref-counting mechanism. */
3068 /* Recursive function that deletes an entire tree and all the common
3069 head structures it points to. */
3072 free_common_tree (gfc_symtree
* common_tree
)
3074 if (common_tree
== NULL
)
3077 free_common_tree (common_tree
->left
);
3078 free_common_tree (common_tree
->right
);
3084 /* Recursive function that deletes an entire tree and all the user
3085 operator nodes that it contains. */
3088 free_uop_tree (gfc_symtree
*uop_tree
)
3090 if (uop_tree
== NULL
)
3093 free_uop_tree (uop_tree
->left
);
3094 free_uop_tree (uop_tree
->right
);
3096 gfc_free_interface (uop_tree
->n
.uop
->op
);
3097 free (uop_tree
->n
.uop
);
3102 /* Recursive function that deletes an entire tree and all the symbols
3103 that it contains. */
3106 free_sym_tree (gfc_symtree
*sym_tree
)
3108 if (sym_tree
== NULL
)
3111 free_sym_tree (sym_tree
->left
);
3112 free_sym_tree (sym_tree
->right
);
3114 gfc_release_symbol (sym_tree
->n
.sym
);
3119 /* Free the derived type list. */
3122 gfc_free_dt_list (void)
3124 gfc_dt_list
*dt
, *n
;
3126 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3132 gfc_derived_types
= NULL
;
3136 /* Free the gfc_equiv_info's. */
3139 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3143 gfc_free_equiv_infos (s
->next
);
3148 /* Free the gfc_equiv_lists. */
3151 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3155 gfc_free_equiv_lists (l
->next
);
3156 gfc_free_equiv_infos (l
->equiv
);
3161 /* Free a finalizer procedure list. */
3164 gfc_free_finalizer (gfc_finalizer
* el
)
3168 gfc_release_symbol (el
->proc_sym
);
3174 gfc_free_finalizer_list (gfc_finalizer
* list
)
3178 gfc_finalizer
* current
= list
;
3180 gfc_free_finalizer (current
);
3185 /* Create a new gfc_charlen structure and add it to a namespace.
3186 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3189 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3192 cl
= gfc_get_charlen ();
3197 /* Put into namespace, but don't allow reject_statement
3198 to free it if old_cl is given. */
3199 gfc_charlen
**prev
= &ns
->cl_list
;
3200 cl
->next
= ns
->old_cl_list
;
3201 while (*prev
!= ns
->old_cl_list
)
3202 prev
= &(*prev
)->next
;
3204 ns
->old_cl_list
= cl
;
3205 cl
->length
= gfc_copy_expr (old_cl
->length
);
3206 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3207 cl
->backend_decl
= old_cl
->backend_decl
;
3208 cl
->passed_length
= old_cl
->passed_length
;
3209 cl
->resolved
= old_cl
->resolved
;
3213 /* Put into namespace. */
3214 cl
->next
= ns
->cl_list
;
3222 /* Free the charlen list from cl to end (end is not freed).
3223 Free the whole list if end is NULL. */
3226 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3230 for (; cl
!= end
; cl
= cl2
)
3235 gfc_free_expr (cl
->length
);
3241 /* Free entry list structs. */
3244 free_entry_list (gfc_entry_list
*el
)
3246 gfc_entry_list
*next
;
3253 free_entry_list (next
);
3257 /* Free a namespace structure and everything below it. Interface
3258 lists associated with intrinsic operators are not freed. These are
3259 taken care of when a specific name is freed. */
3262 gfc_free_namespace (gfc_namespace
*ns
)
3264 gfc_namespace
*p
, *q
;
3273 gcc_assert (ns
->refs
== 0);
3275 gfc_free_statements (ns
->code
);
3277 free_sym_tree (ns
->sym_root
);
3278 free_uop_tree (ns
->uop_root
);
3279 free_common_tree (ns
->common_root
);
3280 free_tb_tree (ns
->tb_sym_root
);
3281 free_tb_tree (ns
->tb_uop_root
);
3282 gfc_free_finalizer_list (ns
->finalizers
);
3283 gfc_free_charlen (ns
->cl_list
, NULL
);
3284 free_st_labels (ns
->st_labels
);
3286 free_entry_list (ns
->entries
);
3287 gfc_free_equiv (ns
->equiv
);
3288 gfc_free_equiv_lists (ns
->equiv_lists
);
3289 gfc_free_use_stmts (ns
->use_stmts
);
3291 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3292 gfc_free_interface (ns
->op
[i
]);
3294 gfc_free_data (ns
->data
);
3298 /* Recursively free any contained namespaces. */
3303 gfc_free_namespace (q
);
3309 gfc_symbol_init_2 (void)
3312 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3317 gfc_symbol_done_2 (void)
3320 gfc_free_namespace (gfc_current_ns
);
3321 gfc_current_ns
= NULL
;
3322 gfc_free_dt_list ();
3326 /* Count how many nodes a symtree has. */
3329 count_st_nodes (const gfc_symtree
*st
)
3335 nodes
= count_st_nodes (st
->left
);
3337 nodes
+= count_st_nodes (st
->right
);
3343 /* Convert symtree tree into symtree vector. */
3346 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
3351 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
3352 st_vec
[node_cntr
++] = st
;
3353 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
3359 /* Traverse namespace. As the functions might modify the symtree, we store the
3360 symtree as a vector and operate on this vector. Note: We assume that
3361 sym_func or st_func never deletes nodes from the symtree - only adding is
3362 allowed. Additionally, newly added nodes are not traversed. */
3365 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
3366 void (*sym_func
) (gfc_symbol
*))
3368 gfc_symtree
**st_vec
;
3369 unsigned nodes
, i
, node_cntr
;
3371 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
3372 nodes
= count_st_nodes (st
);
3373 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
3375 fill_st_vector (st
, st_vec
, node_cntr
);
3380 for (i
= 0; i
< nodes
; i
++)
3381 st_vec
[i
]->n
.sym
->mark
= 0;
3382 for (i
= 0; i
< nodes
; i
++)
3383 if (!st_vec
[i
]->n
.sym
->mark
)
3385 (*sym_func
) (st_vec
[i
]->n
.sym
);
3386 st_vec
[i
]->n
.sym
->mark
= 1;
3390 for (i
= 0; i
< nodes
; i
++)
3391 (*st_func
) (st_vec
[i
]);
3395 /* Recursively traverse the symtree nodes. */
3398 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
3400 do_traverse_symtree (st
, st_func
, NULL
);
3404 /* Call a given function for all symbols in the namespace. We take
3405 care that each gfc_symbol node is called exactly once. */
3408 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
3410 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
3414 /* Return TRUE when name is the name of an intrinsic type. */
3417 gfc_is_intrinsic_typename (const char *name
)
3419 if (strcmp (name
, "integer") == 0
3420 || strcmp (name
, "real") == 0
3421 || strcmp (name
, "character") == 0
3422 || strcmp (name
, "logical") == 0
3423 || strcmp (name
, "complex") == 0
3424 || strcmp (name
, "doubleprecision") == 0
3425 || strcmp (name
, "doublecomplex") == 0)
3432 /* Return TRUE if the symbol is an automatic variable. */
3435 gfc_is_var_automatic (gfc_symbol
*sym
)
3437 /* Pointer and allocatable variables are never automatic. */
3438 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3440 /* Check for arrays with non-constant size. */
3441 if (sym
->attr
.dimension
&& sym
->as
3442 && !gfc_is_compile_time_shape (sym
->as
))
3444 /* Check for non-constant length character variables. */
3445 if (sym
->ts
.type
== BT_CHARACTER
3447 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3452 /* Given a symbol, mark it as SAVEd if it is allowed. */
3455 save_symbol (gfc_symbol
*sym
)
3458 if (sym
->attr
.use_assoc
)
3461 if (sym
->attr
.in_common
3464 || sym
->attr
.flavor
!= FL_VARIABLE
)
3466 /* Automatic objects are not saved. */
3467 if (gfc_is_var_automatic (sym
))
3469 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
3473 /* Mark those symbols which can be SAVEd as such. */
3476 gfc_save_all (gfc_namespace
*ns
)
3478 gfc_traverse_ns (ns
, save_symbol
);
3482 /* Make sure that no changes to symbols are pending. */
3485 gfc_enforce_clean_symbol_state(void)
3487 gcc_assert (changed_syms
== NULL
);
3491 /************** Global symbol handling ************/
3494 /* Search a tree for the global symbol. */
3497 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3506 c
= strcmp (name
, symbol
->name
);
3510 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3517 /* Compare two global symbols. Used for managing the BB tree. */
3520 gsym_compare (void *_s1
, void *_s2
)
3522 gfc_gsymbol
*s1
, *s2
;
3524 s1
= (gfc_gsymbol
*) _s1
;
3525 s2
= (gfc_gsymbol
*) _s2
;
3526 return strcmp (s1
->name
, s2
->name
);
3530 /* Get a global symbol, creating it if it doesn't exist. */
3533 gfc_get_gsymbol (const char *name
)
3537 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3541 s
= XCNEW (gfc_gsymbol
);
3542 s
->type
= GSYM_UNKNOWN
;
3543 s
->name
= gfc_get_string (name
);
3545 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3552 get_iso_c_binding_dt (int sym_id
)
3554 gfc_dt_list
*dt_list
;
3556 dt_list
= gfc_derived_types
;
3558 /* Loop through the derived types in the name list, searching for
3559 the desired symbol from iso_c_binding. Search the parent namespaces
3560 if necessary and requested to (parent_flag). */
3561 while (dt_list
!= NULL
)
3563 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3564 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3565 return dt_list
->derived
;
3567 dt_list
= dt_list
->next
;
3574 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3575 with C. This is necessary for any derived type that is BIND(C) and for
3576 derived types that are parameters to functions that are BIND(C). All
3577 fields of the derived type are required to be interoperable, and are tested
3578 for such. If an error occurs, the errors are reported here, allowing for
3579 multiple errors to be handled for a single derived type. */
3582 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3584 gfc_component
*curr_comp
= NULL
;
3585 gfc_try is_c_interop
= FAILURE
;
3586 gfc_try retval
= SUCCESS
;
3588 if (derived_sym
== NULL
)
3589 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3590 "unexpectedly NULL");
3592 /* If we've already looked at this derived symbol, do not look at it again
3593 so we don't repeat warnings/errors. */
3594 if (derived_sym
->ts
.is_c_interop
)
3597 /* The derived type must have the BIND attribute to be interoperable
3598 J3/04-007, Section 15.2.3. */
3599 if (derived_sym
->attr
.is_bind_c
!= 1)
3601 derived_sym
->ts
.is_c_interop
= 0;
3602 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3603 "attribute to be C interoperable", derived_sym
->name
,
3604 &(derived_sym
->declared_at
));
3608 curr_comp
= derived_sym
->components
;
3610 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3611 empty struct. Section 15.2 in Fortran 2003 states: "The following
3612 subclauses define the conditions under which a Fortran entity is
3613 interoperable. If a Fortran entity is interoperable, an equivalent
3614 entity may be defined by means of C and the Fortran entity is said
3615 to be interoperable with the C entity. There does not have to be such
3616 an interoperating C entity."
3618 if (curr_comp
== NULL
)
3620 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3621 "and may be inaccessible by the C companion processor",
3622 derived_sym
->name
, &(derived_sym
->declared_at
));
3623 derived_sym
->ts
.is_c_interop
= 1;
3624 derived_sym
->attr
.is_bind_c
= 1;
3629 /* Initialize the derived type as being C interoperable.
3630 If we find an error in the components, this will be set false. */
3631 derived_sym
->ts
.is_c_interop
= 1;
3633 /* Loop through the list of components to verify that the kind of
3634 each is a C interoperable type. */
3637 /* The components cannot be pointers (fortran sense).
3638 J3/04-007, Section 15.2.3, C1505. */
3639 if (curr_comp
->attr
.pointer
!= 0)
3641 gfc_error ("Component '%s' at %L cannot have the "
3642 "POINTER attribute because it is a member "
3643 "of the BIND(C) derived type '%s' at %L",
3644 curr_comp
->name
, &(curr_comp
->loc
),
3645 derived_sym
->name
, &(derived_sym
->declared_at
));
3649 if (curr_comp
->attr
.proc_pointer
!= 0)
3651 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3652 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3653 &curr_comp
->loc
, derived_sym
->name
,
3654 &derived_sym
->declared_at
);
3658 /* The components cannot be allocatable.
3659 J3/04-007, Section 15.2.3, C1505. */
3660 if (curr_comp
->attr
.allocatable
!= 0)
3662 gfc_error ("Component '%s' at %L cannot have the "
3663 "ALLOCATABLE attribute because it is a member "
3664 "of the BIND(C) derived type '%s' at %L",
3665 curr_comp
->name
, &(curr_comp
->loc
),
3666 derived_sym
->name
, &(derived_sym
->declared_at
));
3670 /* BIND(C) derived types must have interoperable components. */
3671 if (curr_comp
->ts
.type
== BT_DERIVED
3672 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3673 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3675 /* This should be allowed; the draft says a derived-type can not
3676 have type parameters if it is has the BIND attribute. Type
3677 parameters seem to be for making parameterized derived types.
3678 There's no need to verify the type if it is c_ptr/c_funptr. */
3679 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3683 /* Grab the typespec for the given component and test the kind. */
3684 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
3686 if (is_c_interop
!= SUCCESS
)
3688 /* Report warning and continue since not fatal. The
3689 draft does specify a constraint that requires all fields
3690 to interoperate, but if the user says real(4), etc., it
3691 may interoperate with *something* in C, but the compiler
3692 most likely won't know exactly what. Further, it may not
3693 interoperate with the same data type(s) in C if the user
3694 recompiles with different flags (e.g., -m32 and -m64 on
3695 x86_64 and using integer(4) to claim interop with a
3697 if (derived_sym
->attr
.is_bind_c
== 1)
3698 /* If the derived type is bind(c), all fields must be
3700 gfc_warning ("Component '%s' in derived type '%s' at %L "
3701 "may not be C interoperable, even though "
3702 "derived type '%s' is BIND(C)",
3703 curr_comp
->name
, derived_sym
->name
,
3704 &(curr_comp
->loc
), derived_sym
->name
);
3706 /* If derived type is param to bind(c) routine, or to one
3707 of the iso_c_binding procs, it must be interoperable, so
3708 all fields must interop too. */
3709 gfc_warning ("Component '%s' in derived type '%s' at %L "
3710 "may not be C interoperable",
3711 curr_comp
->name
, derived_sym
->name
,
3716 curr_comp
= curr_comp
->next
;
3717 } while (curr_comp
!= NULL
);
3720 /* Make sure we don't have conflicts with the attributes. */
3721 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3723 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3724 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3725 &(derived_sym
->declared_at
));
3729 if (derived_sym
->attr
.sequence
!= 0)
3731 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3732 "attribute because it is BIND(C)", derived_sym
->name
,
3733 &(derived_sym
->declared_at
));
3737 /* Mark the derived type as not being C interoperable if we found an
3738 error. If there were only warnings, proceed with the assumption
3739 it's interoperable. */
3740 if (retval
== FAILURE
)
3741 derived_sym
->ts
.is_c_interop
= 0;
3747 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3750 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3751 const char *module_name
)
3753 gfc_symtree
*tmp_symtree
;
3754 gfc_symbol
*tmp_sym
;
3757 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3759 if (tmp_symtree
!= NULL
)
3760 tmp_sym
= tmp_symtree
->n
.sym
;
3764 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3765 "create symbol for %s", ptr_name
);
3768 tmp_sym
->ts
.is_c_interop
= 1;
3769 tmp_sym
->attr
.is_c_interop
= 1;
3770 tmp_sym
->ts
.is_iso_c
= 1;
3771 tmp_sym
->ts
.type
= BT_DERIVED
;
3772 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3774 /* The c_ptr and c_funptr derived types will provide the
3775 definition for c_null_ptr and c_null_funptr, respectively. */
3776 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3777 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3779 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3780 if (tmp_sym
->ts
.u
.derived
== NULL
)
3782 /* This can occur if the user forgot to declare c_ptr or
3783 c_funptr and they're trying to use one of the procedures
3784 that has arg(s) of the missing type. In this case, a
3785 regular version of the thing should have been put in the
3788 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3789 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3790 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3793 tmp_sym
->ts
.u
.derived
=
3794 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3795 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3798 /* Module name is some mangled version of iso_c_binding. */
3799 tmp_sym
->module
= gfc_get_string (module_name
);
3801 /* Say it's from the iso_c_binding module. */
3802 tmp_sym
->attr
.is_iso_c
= 1;
3804 tmp_sym
->attr
.use_assoc
= 1;
3805 tmp_sym
->attr
.is_bind_c
= 1;
3806 /* Since we never generate a call to this symbol, don't set the
3809 /* Set the c_address field of c_null_ptr and c_null_funptr to
3810 the value of NULL. */
3811 tmp_sym
->value
= gfc_get_expr ();
3812 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3813 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3814 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
3815 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
3816 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
3817 c
->expr
= gfc_get_expr ();
3818 c
->expr
->expr_type
= EXPR_NULL
;
3819 c
->expr
->ts
.is_iso_c
= 1;
3825 /* Add a formal argument, gfc_formal_arglist, to the
3826 end of the given list of arguments. Set the reference to the
3827 provided symbol, param_sym, in the argument. */
3830 add_formal_arg (gfc_formal_arglist
**head
,
3831 gfc_formal_arglist
**tail
,
3832 gfc_formal_arglist
*formal_arg
,
3833 gfc_symbol
*param_sym
)
3835 /* Put in list, either as first arg or at the tail (curr arg). */
3837 *head
= *tail
= formal_arg
;
3840 (*tail
)->next
= formal_arg
;
3841 (*tail
) = formal_arg
;
3844 (*tail
)->sym
= param_sym
;
3845 (*tail
)->next
= NULL
;
3851 /* Generates a symbol representing the CPTR argument to an
3852 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3853 CPTR and add it to the provided argument list. */
3856 gen_cptr_param (gfc_formal_arglist
**head
,
3857 gfc_formal_arglist
**tail
,
3858 const char *module_name
,
3859 gfc_namespace
*ns
, const char *c_ptr_name
,
3862 gfc_symbol
*param_sym
= NULL
;
3863 gfc_symbol
*c_ptr_sym
= NULL
;
3864 gfc_symtree
*param_symtree
= NULL
;
3865 gfc_formal_arglist
*formal_arg
= NULL
;
3866 const char *c_ptr_in
;
3867 const char *c_ptr_type
= NULL
;
3869 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3870 c_ptr_type
= "c_funptr";
3872 c_ptr_type
= "c_ptr";
3874 if(c_ptr_name
== NULL
)
3875 c_ptr_in
= "gfc_cptr__";
3877 c_ptr_in
= c_ptr_name
;
3878 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
, false);
3879 if (param_symtree
!= NULL
)
3880 param_sym
= param_symtree
->n
.sym
;
3882 gfc_internal_error ("gen_cptr_param(): Unable to "
3883 "create symbol for %s", c_ptr_in
);
3885 /* Set up the appropriate fields for the new c_ptr param sym. */
3887 param_sym
->attr
.flavor
= FL_DERIVED
;
3888 param_sym
->ts
.type
= BT_DERIVED
;
3889 param_sym
->attr
.intent
= INTENT_IN
;
3890 param_sym
->attr
.dummy
= 1;
3892 /* This will pass the ptr to the iso_c routines as a (void *). */
3893 param_sym
->attr
.value
= 1;
3894 param_sym
->attr
.use_assoc
= 1;
3896 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3898 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3899 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3901 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3902 if (c_ptr_sym
== NULL
)
3904 /* This can happen if the user did not define c_ptr but they are
3905 trying to use one of the iso_c_binding functions that need it. */
3906 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3907 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3908 (const char *)c_ptr_type
);
3910 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3911 (const char *)c_ptr_type
);
3913 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3916 param_sym
->ts
.u
.derived
= c_ptr_sym
;
3917 param_sym
->module
= gfc_get_string (module_name
);
3919 /* Make new formal arg. */
3920 formal_arg
= gfc_get_formal_arglist ();
3921 /* Add arg to list of formal args (the CPTR arg). */
3922 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3924 /* Validate changes. */
3925 gfc_commit_symbol (param_sym
);
3929 /* Generates a symbol representing the FPTR argument to an
3930 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3931 FPTR and add it to the provided argument list. */
3934 gen_fptr_param (gfc_formal_arglist
**head
,
3935 gfc_formal_arglist
**tail
,
3936 const char *module_name
,
3937 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3939 gfc_symbol
*param_sym
= NULL
;
3940 gfc_symtree
*param_symtree
= NULL
;
3941 gfc_formal_arglist
*formal_arg
= NULL
;
3942 const char *f_ptr_out
= "gfc_fptr__";
3944 if (f_ptr_name
!= NULL
)
3945 f_ptr_out
= f_ptr_name
;
3947 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
, false);
3948 if (param_symtree
!= NULL
)
3949 param_sym
= param_symtree
->n
.sym
;
3951 gfc_internal_error ("generateFPtrParam(): Unable to "
3952 "create symbol for %s", f_ptr_out
);
3954 /* Set up the necessary fields for the fptr output param sym. */
3957 param_sym
->attr
.proc_pointer
= 1;
3959 param_sym
->attr
.pointer
= 1;
3960 param_sym
->attr
.dummy
= 1;
3961 param_sym
->attr
.use_assoc
= 1;
3963 /* ISO C Binding type to allow any pointer type as actual param. */
3964 param_sym
->ts
.type
= BT_VOID
;
3965 param_sym
->module
= gfc_get_string (module_name
);
3968 formal_arg
= gfc_get_formal_arglist ();
3969 /* Add arg to list of formal args. */
3970 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3972 /* Validate changes. */
3973 gfc_commit_symbol (param_sym
);
3977 /* Generates a symbol representing the optional SHAPE argument for the
3978 iso_c_binding c_f_pointer() procedure. Also, create a
3979 gfc_formal_arglist for the SHAPE and add it to the provided
3983 gen_shape_param (gfc_formal_arglist
**head
,
3984 gfc_formal_arglist
**tail
,
3985 const char *module_name
,
3986 gfc_namespace
*ns
, const char *shape_param_name
)
3988 gfc_symbol
*param_sym
= NULL
;
3989 gfc_symtree
*param_symtree
= NULL
;
3990 gfc_formal_arglist
*formal_arg
= NULL
;
3991 const char *shape_param
= "gfc_shape_array__";
3993 if (shape_param_name
!= NULL
)
3994 shape_param
= shape_param_name
;
3996 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
, false);
3997 if (param_symtree
!= NULL
)
3998 param_sym
= param_symtree
->n
.sym
;
4000 gfc_internal_error ("generateShapeParam(): Unable to "
4001 "create symbol for %s", shape_param
);
4003 /* Set up the necessary fields for the shape input param sym. */
4005 param_sym
->attr
.dummy
= 1;
4006 param_sym
->attr
.use_assoc
= 1;
4008 /* Integer array, rank 1, describing the shape of the object. Make it's
4009 type BT_VOID initially so we can accept any type/kind combination of
4010 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
4011 of BT_INTEGER type. */
4012 param_sym
->ts
.type
= BT_VOID
;
4014 /* Initialize the kind to default integer. However, it will be overridden
4015 during resolution to match the kind of the SHAPE parameter given as
4016 the actual argument (to allow for any valid integer kind). */
4017 param_sym
->ts
.kind
= gfc_default_integer_kind
;
4018 param_sym
->as
= gfc_get_array_spec ();
4020 param_sym
->as
->rank
= 1;
4021 param_sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
4024 /* The extent is unknown until we get it. The length give us
4025 the rank the incoming pointer. */
4026 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
4028 /* The arg is also optional; it is required iff the second arg
4029 (fptr) is to an array, otherwise, it's ignored. */
4030 param_sym
->attr
.optional
= 1;
4031 param_sym
->attr
.intent
= INTENT_IN
;
4032 param_sym
->attr
.dimension
= 1;
4033 param_sym
->module
= gfc_get_string (module_name
);
4036 formal_arg
= gfc_get_formal_arglist ();
4037 /* Add arg to list of formal args. */
4038 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
4040 /* Validate changes. */
4041 gfc_commit_symbol (param_sym
);
4045 /* Add a procedure interface to the given symbol (i.e., store a
4046 reference to the list of formal arguments). */
4049 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
4050 gfc_formal_arglist
*formal
)
4053 sym
->formal
= formal
;
4054 sym
->attr
.if_source
= source
;
4058 /* Copy the formal args from an existing symbol, src, into a new
4059 symbol, dest. New formal args are created, and the description of
4060 each arg is set according to the existing ones. This function is
4061 used when creating procedure declaration variables from a procedure
4062 declaration statement (see match_proc_decl()) to create the formal
4063 args based on the args of a given named interface. */
4066 gfc_copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
4068 gfc_formal_arglist
*head
= NULL
;
4069 gfc_formal_arglist
*tail
= NULL
;
4070 gfc_formal_arglist
*formal_arg
= NULL
;
4071 gfc_formal_arglist
*curr_arg
= NULL
;
4072 gfc_formal_arglist
*formal_prev
= NULL
;
4073 /* Save current namespace so we can change it for formal args. */
4074 gfc_namespace
*parent_ns
= gfc_current_ns
;
4076 /* Create a new namespace, which will be the formal ns (namespace
4077 of the formal args). */
4078 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4079 gfc_current_ns
->proc_name
= dest
;
4081 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4083 formal_arg
= gfc_get_formal_arglist ();
4084 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4086 /* May need to copy more info for the symbol. */
4087 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4088 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4089 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4090 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4092 /* If this isn't the first arg, set up the next ptr. For the
4093 last arg built, the formal_arg->next will never get set to
4094 anything other than NULL. */
4095 if (formal_prev
!= NULL
)
4096 formal_prev
->next
= formal_arg
;
4098 formal_arg
->next
= NULL
;
4100 formal_prev
= formal_arg
;
4102 /* Add arg to list of formal args. */
4103 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4105 /* Validate changes. */
4106 gfc_commit_symbol (formal_arg
->sym
);
4109 /* Add the interface to the symbol. */
4110 add_proc_interface (dest
, IFSRC_DECL
, head
);
4112 /* Store the formal namespace information. */
4113 if (dest
->formal
!= NULL
)
4114 /* The current ns should be that for the dest proc. */
4115 dest
->formal_ns
= gfc_current_ns
;
4116 /* Restore the current namespace to what it was on entry. */
4117 gfc_current_ns
= parent_ns
;
4122 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
4124 gfc_formal_arglist
*head
= NULL
;
4125 gfc_formal_arglist
*tail
= NULL
;
4126 gfc_formal_arglist
*formal_arg
= NULL
;
4127 gfc_intrinsic_arg
*curr_arg
= NULL
;
4128 gfc_formal_arglist
*formal_prev
= NULL
;
4129 /* Save current namespace so we can change it for formal args. */
4130 gfc_namespace
*parent_ns
= gfc_current_ns
;
4132 /* Create a new namespace, which will be the formal ns (namespace
4133 of the formal args). */
4134 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4135 gfc_current_ns
->proc_name
= dest
;
4137 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4139 formal_arg
= gfc_get_formal_arglist ();
4140 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4142 /* May need to copy more info for the symbol. */
4143 formal_arg
->sym
->ts
= curr_arg
->ts
;
4144 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4145 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4146 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4147 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4148 formal_arg
->sym
->attr
.dummy
= 1;
4150 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4151 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4153 /* If this isn't the first arg, set up the next ptr. For the
4154 last arg built, the formal_arg->next will never get set to
4155 anything other than NULL. */
4156 if (formal_prev
!= NULL
)
4157 formal_prev
->next
= formal_arg
;
4159 formal_arg
->next
= NULL
;
4161 formal_prev
= formal_arg
;
4163 /* Add arg to list of formal args. */
4164 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4166 /* Validate changes. */
4167 gfc_commit_symbol (formal_arg
->sym
);
4170 /* Add the interface to the symbol. */
4171 add_proc_interface (dest
, IFSRC_DECL
, head
);
4173 /* Store the formal namespace information. */
4174 if (dest
->formal
!= NULL
)
4175 /* The current ns should be that for the dest proc. */
4176 dest
->formal_ns
= gfc_current_ns
;
4177 /* Restore the current namespace to what it was on entry. */
4178 gfc_current_ns
= parent_ns
;
4183 gfc_copy_formal_args_ppc (gfc_component
*dest
, gfc_symbol
*src
)
4185 gfc_formal_arglist
*head
= NULL
;
4186 gfc_formal_arglist
*tail
= NULL
;
4187 gfc_formal_arglist
*formal_arg
= NULL
;
4188 gfc_formal_arglist
*curr_arg
= NULL
;
4189 gfc_formal_arglist
*formal_prev
= NULL
;
4190 /* Save current namespace so we can change it for formal args. */
4191 gfc_namespace
*parent_ns
= gfc_current_ns
;
4193 /* Create a new namespace, which will be the formal ns (namespace
4194 of the formal args). */
4195 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4196 /* TODO: gfc_current_ns->proc_name = dest;*/
4198 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4200 formal_arg
= gfc_get_formal_arglist ();
4201 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4203 /* May need to copy more info for the symbol. */
4204 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4205 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4206 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4207 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4209 /* If this isn't the first arg, set up the next ptr. For the
4210 last arg built, the formal_arg->next will never get set to
4211 anything other than NULL. */
4212 if (formal_prev
!= NULL
)
4213 formal_prev
->next
= formal_arg
;
4215 formal_arg
->next
= NULL
;
4217 formal_prev
= formal_arg
;
4219 /* Add arg to list of formal args. */
4220 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4222 /* Validate changes. */
4223 gfc_commit_symbol (formal_arg
->sym
);
4226 /* Add the interface to the symbol. */
4227 gfc_free_formal_arglist (dest
->formal
);
4228 dest
->formal
= head
;
4229 dest
->attr
.if_source
= IFSRC_DECL
;
4231 /* Store the formal namespace information. */
4232 if (dest
->formal
!= NULL
)
4233 /* The current ns should be that for the dest proc. */
4234 dest
->formal_ns
= gfc_current_ns
;
4235 /* Restore the current namespace to what it was on entry. */
4236 gfc_current_ns
= parent_ns
;
4240 /* Builds the parameter list for the iso_c_binding procedure
4241 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4242 generic version of either the c_f_pointer or c_f_procpointer
4243 functions. The new_proc_sym represents a "resolved" version of the
4244 symbol. The functions are resolved to match the types of their
4245 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4246 something similar to c_f_pointer_i4 if the type of data object fptr
4247 pointed to was a default integer. The actual name of the resolved
4248 procedure symbol is further mangled with the module name, etc., but
4249 the idea holds true. */
4252 build_formal_args (gfc_symbol
*new_proc_sym
,
4253 gfc_symbol
*old_sym
, int add_optional_arg
)
4255 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
4256 gfc_namespace
*parent_ns
= NULL
;
4258 parent_ns
= gfc_current_ns
;
4259 /* Create a new namespace, which will be the formal ns (namespace
4260 of the formal args). */
4261 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
4262 gfc_current_ns
->proc_name
= new_proc_sym
;
4264 /* Generate the params. */
4265 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
4267 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4268 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4269 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4270 gfc_current_ns
, "fptr", 1);
4272 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
4274 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4275 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4276 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4277 gfc_current_ns
, "fptr", 0);
4278 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4279 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
4280 gfc_current_ns
, "shape");
4283 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
4285 /* c_associated has one required arg and one optional; both
4287 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4288 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
4289 if (add_optional_arg
)
4291 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4292 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
4293 /* The last param is optional so mark it as such. */
4294 tail
->sym
->attr
.optional
= 1;
4298 /* Add the interface (store formal args to new_proc_sym). */
4299 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
4301 /* Set up the formal_ns pointer to the one created for the
4302 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4303 new_proc_sym
->formal_ns
= gfc_current_ns
;
4305 gfc_current_ns
= parent_ns
;
4309 std_for_isocbinding_symbol (int id
)
4313 #define NAMED_INTCST(a,b,c,d) \
4316 #include "iso-c-binding.def"
4319 #define NAMED_FUNCTION(a,b,c,d) \
4322 #include "iso-c-binding.def"
4323 #undef NAMED_FUNCTION
4326 return GFC_STD_F2003
;
4330 /* Generate the given set of C interoperable kind objects, or all
4331 interoperable kinds. This function will only be given kind objects
4332 for valid iso_c_binding defined types because this is verified when
4333 the 'use' statement is parsed. If the user gives an 'only' clause,
4334 the specific kinds are looked up; if they don't exist, an error is
4335 reported. If the user does not give an 'only' clause, all
4336 iso_c_binding symbols are generated. If a list of specific kinds
4337 is given, it must have a NULL in the first empty spot to mark the
4342 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4343 const char *local_name
)
4345 const char *const name
= (local_name
&& local_name
[0]) ? local_name
4346 : c_interop_kinds_table
[s
].name
;
4347 gfc_symtree
*tmp_symtree
= NULL
;
4348 gfc_symbol
*tmp_sym
= NULL
;
4351 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4354 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4356 /* Already exists in this scope so don't re-add it. */
4357 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4358 && (!tmp_sym
->attr
.generic
4359 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4360 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4362 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4363 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4365 gfc_dt_list
*dt_list
;
4366 dt_list
= gfc_get_dt_list ();
4367 dt_list
->derived
= tmp_sym
;
4368 dt_list
->next
= gfc_derived_types
;
4369 gfc_derived_types
= dt_list
;
4375 /* Create the sym tree in the current ns. */
4376 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4378 tmp_sym
= tmp_symtree
->n
.sym
;
4380 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4383 /* Say what module this symbol belongs to. */
4384 tmp_sym
->module
= gfc_get_string (mod_name
);
4385 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4386 tmp_sym
->intmod_sym_id
= s
;
4391 #define NAMED_INTCST(a,b,c,d) case a :
4392 #define NAMED_REALCST(a,b,c,d) case a :
4393 #define NAMED_CMPXCST(a,b,c,d) case a :
4394 #define NAMED_LOGCST(a,b,c) case a :
4395 #define NAMED_CHARKNDCST(a,b,c) case a :
4396 #include "iso-c-binding.def"
4398 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4399 c_interop_kinds_table
[s
].value
);
4401 /* Initialize an integer constant expression node. */
4402 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4403 tmp_sym
->ts
.type
= BT_INTEGER
;
4404 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4406 /* Mark this type as a C interoperable one. */
4407 tmp_sym
->ts
.is_c_interop
= 1;
4408 tmp_sym
->ts
.is_iso_c
= 1;
4409 tmp_sym
->value
->ts
.is_c_interop
= 1;
4410 tmp_sym
->value
->ts
.is_iso_c
= 1;
4411 tmp_sym
->attr
.is_c_interop
= 1;
4413 /* Tell what f90 type this c interop kind is valid. */
4414 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4416 /* Say it's from the iso_c_binding module. */
4417 tmp_sym
->attr
.is_iso_c
= 1;
4419 /* Make it use associated. */
4420 tmp_sym
->attr
.use_assoc
= 1;
4424 #define NAMED_CHARCST(a,b,c) case a :
4425 #include "iso-c-binding.def"
4427 /* Initialize an integer constant expression node for the
4428 length of the character. */
4429 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4430 &gfc_current_locus
, NULL
, 1);
4431 tmp_sym
->value
->ts
.is_c_interop
= 1;
4432 tmp_sym
->value
->ts
.is_iso_c
= 1;
4433 tmp_sym
->value
->value
.character
.length
= 1;
4434 tmp_sym
->value
->value
.character
.string
[0]
4435 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4436 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4437 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4440 /* May not need this in both attr and ts, but do need in
4441 attr for writing module file. */
4442 tmp_sym
->attr
.is_c_interop
= 1;
4444 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4445 tmp_sym
->ts
.type
= BT_CHARACTER
;
4447 /* Need to set it to the C_CHAR kind. */
4448 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4450 /* Mark this type as a C interoperable one. */
4451 tmp_sym
->ts
.is_c_interop
= 1;
4452 tmp_sym
->ts
.is_iso_c
= 1;
4454 /* Tell what f90 type this c interop kind is valid. */
4455 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4457 /* Say it's from the iso_c_binding module. */
4458 tmp_sym
->attr
.is_iso_c
= 1;
4460 /* Make it use associated. */
4461 tmp_sym
->attr
.use_assoc
= 1;
4464 case ISOCBINDING_PTR
:
4465 case ISOCBINDING_FUNPTR
:
4467 gfc_interface
*intr
, *head
;
4469 const char *hidden_name
;
4470 gfc_dt_list
**dt_list_ptr
= NULL
;
4471 gfc_component
*tmp_comp
= NULL
;
4472 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
4474 hidden_name
= gfc_get_string ("%c%s",
4475 (char) TOUPPER ((unsigned char) tmp_sym
->name
[0]),
4478 /* Generate real derived type. */
4479 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4482 if (tmp_symtree
!= NULL
)
4484 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4486 dt_sym
= tmp_symtree
->n
.sym
;
4490 /* Generate an artificial generic function. */
4491 dt_sym
->name
= gfc_get_string (tmp_sym
->name
);
4492 head
= tmp_sym
->generic
;
4493 intr
= gfc_get_interface ();
4495 intr
->where
= gfc_current_locus
;
4497 tmp_sym
->generic
= intr
;
4499 if (!tmp_sym
->attr
.generic
4500 && gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
)
4504 if (!tmp_sym
->attr
.function
4505 && gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
)
4509 /* Say what module this symbol belongs to. */
4510 dt_sym
->module
= gfc_get_string (mod_name
);
4511 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4512 dt_sym
->intmod_sym_id
= s
;
4514 /* Initialize an integer constant expression node. */
4515 dt_sym
->attr
.flavor
= FL_DERIVED
;
4516 dt_sym
->ts
.is_c_interop
= 1;
4517 dt_sym
->attr
.is_c_interop
= 1;
4518 dt_sym
->attr
.is_iso_c
= 1;
4519 dt_sym
->ts
.is_iso_c
= 1;
4520 dt_sym
->ts
.type
= BT_DERIVED
;
4522 /* A derived type must have the bind attribute to be
4523 interoperable (J3/04-007, Section 15.2.3), even though
4524 the binding label is not used. */
4525 dt_sym
->attr
.is_bind_c
= 1;
4527 dt_sym
->attr
.referenced
= 1;
4528 dt_sym
->ts
.u
.derived
= dt_sym
;
4530 /* Add the symbol created for the derived type to the current ns. */
4531 dt_list_ptr
= &(gfc_derived_types
);
4532 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4533 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4535 /* There is already at least one derived type in the list, so append
4536 the one we're currently building for c_ptr or c_funptr. */
4537 if (*dt_list_ptr
!= NULL
)
4538 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4539 (*dt_list_ptr
) = gfc_get_dt_list ();
4540 (*dt_list_ptr
)->derived
= dt_sym
;
4541 (*dt_list_ptr
)->next
= NULL
;
4543 /* Set up the component of the derived type, which will be
4544 an integer with kind equal to c_ptr_size. Mangle the name of
4545 the field for the c_address to prevent the curious user from
4546 trying to access it from Fortran. */
4547 sprintf (comp_name
, "__%s_%s", dt_sym
->name
, "c_address");
4548 gfc_add_component (dt_sym
, comp_name
, &tmp_comp
);
4549 if (tmp_comp
== NULL
)
4550 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4551 "create component for c_address");
4553 tmp_comp
->ts
.type
= BT_INTEGER
;
4555 /* Set this because the module will need to read/write this field. */
4556 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4558 /* The kinds for c_ptr and c_funptr are the same. */
4559 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4560 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4562 tmp_comp
->attr
.pointer
= 0;
4563 tmp_comp
->attr
.dimension
= 0;
4565 /* Mark the component as C interoperable. */
4566 tmp_comp
->ts
.is_c_interop
= 1;
4568 /* Make it use associated (iso_c_binding module). */
4569 dt_sym
->attr
.use_assoc
= 1;
4574 case ISOCBINDING_NULL_PTR
:
4575 case ISOCBINDING_NULL_FUNPTR
:
4576 gen_special_c_interop_ptr (s
, name
, mod_name
);
4579 case ISOCBINDING_F_POINTER
:
4580 case ISOCBINDING_ASSOCIATED
:
4581 case ISOCBINDING_LOC
:
4582 case ISOCBINDING_FUNLOC
:
4583 case ISOCBINDING_F_PROCPOINTER
:
4585 tmp_sym
->attr
.proc
= PROC_MODULE
;
4587 /* Use the procedure's name as it is in the iso_c_binding module for
4588 setting the binding label in case the user renamed the symbol. */
4589 tmp_sym
->binding_label
=
4590 gfc_get_string ("%s_%s", mod_name
,
4591 c_interop_kinds_table
[s
].name
);
4592 tmp_sym
->attr
.is_iso_c
= 1;
4593 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4594 tmp_sym
->attr
.subroutine
= 1;
4597 /* TODO! This needs to be finished more for the expr of the
4598 function or something!
4599 This may not need to be here, because trying to do c_loc
4601 if (s
== ISOCBINDING_ASSOCIATED
)
4603 tmp_sym
->attr
.function
= 1;
4604 tmp_sym
->ts
.type
= BT_LOGICAL
;
4605 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4606 tmp_sym
->result
= tmp_sym
;
4610 /* Here, we're taking the simple approach. We're defining
4611 c_loc as an external identifier so the compiler will put
4612 what we expect on the stack for the address we want the
4614 tmp_sym
->ts
.type
= BT_DERIVED
;
4615 if (s
== ISOCBINDING_LOC
)
4616 tmp_sym
->ts
.u
.derived
=
4617 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4619 tmp_sym
->ts
.u
.derived
=
4620 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4622 if (tmp_sym
->ts
.u
.derived
== NULL
)
4624 /* Create the necessary derived type so we can continue
4625 processing the file. */
4626 generate_isocbinding_symbol
4627 (mod_name
, s
== ISOCBINDING_FUNLOC
4628 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4629 (const char *)(s
== ISOCBINDING_FUNLOC
4630 ? "c_funptr" : "c_ptr"));
4631 tmp_sym
->ts
.u
.derived
=
4632 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4633 ? ISOCBINDING_FUNPTR
4637 /* The function result is itself (no result clause). */
4638 tmp_sym
->result
= tmp_sym
;
4639 tmp_sym
->attr
.external
= 1;
4640 tmp_sym
->attr
.use_assoc
= 0;
4641 tmp_sym
->attr
.pure
= 1;
4642 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4643 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4647 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4648 tmp_sym
->attr
.contained
= 0;
4650 /* Try using this builder routine, with the new and old symbols
4651 both being the generic iso_c proc sym being created. This
4652 will create the formal args (and the new namespace for them).
4653 Don't build an arg list for c_loc because we're going to treat
4654 c_loc as an external procedure. */
4655 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4656 /* The 1 says to add any optional args, if applicable. */
4657 build_formal_args (tmp_sym
, tmp_sym
, 1);
4659 /* Set this after setting up the symbol, to prevent error messages. */
4660 tmp_sym
->attr
.use_assoc
= 1;
4662 /* This symbol will not be referenced directly. It will be
4663 resolved to the implementation for the given f90 kind. */
4664 tmp_sym
->attr
.referenced
= 0;
4671 gfc_commit_symbol (tmp_sym
);
4675 /* Creates a new symbol based off of an old iso_c symbol, with a new
4676 binding label. This function can be used to create a new,
4677 resolved, version of a procedure symbol for c_f_pointer or
4678 c_f_procpointer that is based on the generic symbols. A new
4679 parameter list is created for the new symbol using
4680 build_formal_args(). The add_optional_flag specifies whether the
4681 to add the optional SHAPE argument. The new symbol is
4685 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4686 const char *new_binding_label
, int add_optional_arg
)
4688 gfc_symtree
*new_symtree
= NULL
;
4690 /* See if we have a symbol by that name already available, looking
4691 through any parent namespaces. */
4692 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4693 if (new_symtree
!= NULL
)
4694 /* Return the existing symbol. */
4695 return new_symtree
->n
.sym
;
4697 /* Create the symtree/symbol, with attempted host association. */
4698 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4699 if (new_symtree
== NULL
)
4700 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4701 "symtree for '%s'", new_name
);
4703 /* Now fill in the fields of the resolved symbol with the old sym. */
4704 new_symtree
->n
.sym
->binding_label
= new_binding_label
;
4705 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4706 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4707 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4708 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4709 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4710 if (old_sym
->attr
.function
)
4711 new_symtree
->n
.sym
->result
= new_symtree
->n
.sym
;
4712 /* Build the formal arg list. */
4713 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4715 gfc_commit_symbol (new_symtree
->n
.sym
);
4717 return new_symtree
->n
.sym
;
4721 /* Check that a symbol is already typed. If strict is not set, an untyped
4722 symbol is acceptable for non-standard-conforming mode. */
4725 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4726 bool strict
, locus where
)
4730 if (gfc_matching_prefix
)
4733 /* Check for the type and try to give it an implicit one. */
4734 if (sym
->ts
.type
== BT_UNKNOWN
4735 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4739 gfc_error ("Symbol '%s' is used before it is typed at %L",
4744 if (gfc_notify_std (GFC_STD_GNU
,
4745 "Extension: Symbol '%s' is used before"
4746 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4750 /* Everything is ok. */
4755 /* Construct a typebound-procedure structure. Those are stored in a tentative
4756 list and marked `error' until symbols are committed. */
4759 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4761 gfc_typebound_proc
*result
;
4762 tentative_tbp
*list_node
;
4764 result
= XCNEW (gfc_typebound_proc
);
4769 list_node
= XCNEW (tentative_tbp
);
4770 list_node
->next
= tentative_tbp_list
;
4771 list_node
->proc
= result
;
4772 tentative_tbp_list
= list_node
;
4778 /* Get the super-type of a given derived type. */
4781 gfc_get_derived_super_type (gfc_symbol
* derived
)
4783 if (derived
&& derived
->attr
.generic
)
4784 derived
= gfc_find_dt_in_generic (derived
);
4786 if (!derived
->attr
.extension
)
4789 gcc_assert (derived
->components
);
4790 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4791 gcc_assert (derived
->components
->ts
.u
.derived
);
4793 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4794 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4796 return derived
->components
->ts
.u
.derived
;
4800 /* Get the ultimate super-type of a given derived type. */
4803 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4805 if (!derived
->attr
.extension
)
4808 derived
= gfc_get_derived_super_type (derived
);
4810 if (derived
->attr
.extension
)
4811 return gfc_get_ultimate_derived_super_type (derived
);
4817 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4820 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4822 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4823 t2
= gfc_get_derived_super_type (t2
);
4824 return gfc_compare_derived_types (t1
, t2
);
4828 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4829 If ts1 is nonpolymorphic, ts2 must be the same type.
4830 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4833 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4835 bool is_class1
= (ts1
->type
== BT_CLASS
);
4836 bool is_class2
= (ts2
->type
== BT_CLASS
);
4837 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4838 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4840 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
)
4841 return (ts1
->type
== ts2
->type
);
4843 if (is_derived1
&& is_derived2
)
4844 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4846 if (is_class1
&& is_derived2
)
4847 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4849 else if (is_class1
&& is_class2
)
4850 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4851 ts2
->u
.derived
->components
->ts
.u
.derived
);
4857 /* Find the parent-namespace of the current function. If we're inside
4858 BLOCK constructs, it may not be the current one. */
4861 gfc_find_proc_namespace (gfc_namespace
* ns
)
4863 while (ns
->construct_entities
)
4873 /* Check if an associate-variable should be translated as an `implicit' pointer
4874 internally (if it is associated to a variable and not an array with
4878 gfc_is_associate_pointer (gfc_symbol
* sym
)
4883 if (!sym
->assoc
->variable
)
4886 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
4894 gfc_find_dt_in_generic (gfc_symbol
*sym
)
4896 gfc_interface
*intr
= NULL
;
4898 if (!sym
|| sym
->attr
.flavor
== FL_DERIVED
)
4901 if (sym
->attr
.generic
)
4902 for (intr
= (sym
? sym
->generic
: NULL
); intr
; intr
= intr
->next
)
4903 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
4905 return intr
? intr
->sym
: NULL
;