1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2020 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
29 #include "constructor.h"
32 /* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
36 const mstring flavors
[] =
38 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
39 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
40 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
41 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
42 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 minit ("UNION", FL_UNION
), minit ("STRUCTURE", FL_STRUCT
),
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 /* Set the mstrings for DTIO procedure names. */
91 const mstring dtio_procs
[] =
93 minit ("_dtio_formatted_read", DTIO_RF
),
94 minit ("_dtio_formatted_write", DTIO_WF
),
95 minit ("_dtio_unformatted_read", DTIO_RUF
),
96 minit ("_dtio_unformatted_write", DTIO_WUF
),
99 /* This is to make sure the backend generates setup code in the correct
102 static int next_dummy_order
= 1;
105 gfc_namespace
*gfc_current_ns
;
106 gfc_namespace
*gfc_global_ns_list
;
108 gfc_gsymbol
*gfc_gsym_root
= NULL
;
110 gfc_symbol
*gfc_derived_types
;
112 static gfc_undo_change_set default_undo_chgset_var
= { vNULL
, vNULL
, NULL
};
113 static gfc_undo_change_set
*latest_undo_chgset
= &default_undo_chgset_var
;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag
[GFC_LETTERS
];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (bool type
, bool external
, locus
*loc
)
132 gfc_current_ns
->has_implicit_none_export
= 1;
136 gfc_current_ns
->seen_implicit_none
= 1;
137 for (i
= 0; i
< GFC_LETTERS
; i
++)
139 if (gfc_current_ns
->set_flag
[i
])
141 gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
142 "IMPLICIT statement", loc
);
145 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
146 gfc_current_ns
->set_flag
[i
] = 1;
152 /* Reset the implicit range flags. */
155 gfc_clear_new_implicit (void)
159 for (i
= 0; i
< GFC_LETTERS
; i
++)
164 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
167 gfc_add_new_implicit_range (int c1
, int c2
)
174 for (i
= c1
; i
<= c2
; i
++)
178 gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
190 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
191 the new implicit types back into the existing types will work. */
194 gfc_merge_new_implicit (gfc_typespec
*ts
)
198 if (gfc_current_ns
->seen_implicit_none
)
200 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
204 for (i
= 0; i
< GFC_LETTERS
; i
++)
208 if (gfc_current_ns
->set_flag
[i
])
210 gfc_error ("Letter %qc already has an IMPLICIT type at %C",
215 gfc_current_ns
->default_type
[i
] = *ts
;
216 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
217 gfc_current_ns
->set_flag
[i
] = 1;
224 /* Given a symbol, return a pointer to the typespec for its default type. */
227 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
233 if (flag_allow_leading_underscore
&& letter
== '_')
234 gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
235 "gfortran developers, and should not be used for "
236 "implicitly typed variables");
238 if (letter
< 'a' || letter
> 'z')
239 gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name
);
244 return &ns
->default_type
[letter
- 'a'];
248 /* Recursively append candidate SYM to CANDIDATES. Store the number of
249 candidates in CANDIDATES_LEN. */
252 lookup_symbol_fuzzy_find_candidates (gfc_symtree
*sym
,
254 size_t &candidates_len
)
261 if (sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
&& sym
->n
.sym
->ts
.type
!= BT_PROCEDURE
)
262 vec_push (candidates
, candidates_len
, sym
->name
);
265 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
269 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
273 /* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
276 lookup_symbol_fuzzy (const char *sym_name
, gfc_symbol
*symbol
)
278 char **candidates
= NULL
;
279 size_t candidates_len
= 0;
280 lookup_symbol_fuzzy_find_candidates (symbol
->ns
->sym_root
, candidates
,
282 return gfc_closest_fuzzy_match (sym_name
, candidates
);
286 /* Given a pointer to a symbol, set its type according to the first
287 letter of its name. Fails if the letter in question has no default
291 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
295 if (sym
->ts
.type
!= BT_UNKNOWN
)
296 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
298 ts
= gfc_get_default_type (sym
->name
, ns
);
300 if (ts
->type
== BT_UNKNOWN
)
302 if (error_flag
&& !sym
->attr
.untyped
)
304 const char *guessed
= lookup_symbol_fuzzy (sym
->name
, sym
);
306 gfc_error ("Symbol %qs at %L has no IMPLICIT type"
307 "; did you mean %qs?",
308 sym
->name
, &sym
->declared_at
, guessed
);
310 gfc_error ("Symbol %qs at %L has no IMPLICIT type",
311 sym
->name
, &sym
->declared_at
);
312 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
319 sym
->attr
.implicit_type
= 1;
321 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
322 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
323 else if (ts
->type
== BT_CLASS
324 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
327 if (sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
329 /* BIND(C) variables should not be implicitly declared. */
330 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared BIND(C) "
331 "variable %qs at %L may not be C interoperable",
332 sym
->name
, &sym
->declared_at
);
333 sym
->ts
.f90_type
= sym
->ts
.type
;
336 if (sym
->attr
.dummy
!= 0)
338 if (sym
->ns
->proc_name
!= NULL
339 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
340 || sym
->ns
->proc_name
->attr
.function
!= 0)
341 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0
342 && warn_c_binding_type
)
344 /* Dummy args to a BIND(C) routine may not be interoperable if
345 they are implicitly typed. */
346 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared variable "
347 "%qs at %L may not be C interoperable but it is a "
348 "dummy argument to the BIND(C) procedure %qs at %L",
349 sym
->name
, &(sym
->declared_at
),
350 sym
->ns
->proc_name
->name
,
351 &(sym
->ns
->proc_name
->declared_at
));
352 sym
->ts
.f90_type
= sym
->ts
.type
;
360 /* This function is called from parse.c(parse_progunit) to check the
361 type of the function is not implicitly typed in the host namespace
362 and to implicitly type the function result, if necessary. */
365 gfc_check_function_type (gfc_namespace
*ns
)
367 gfc_symbol
*proc
= ns
->proc_name
;
369 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
372 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
374 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
))
376 if (proc
->result
!= proc
)
378 proc
->ts
= proc
->result
->ts
;
379 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
380 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
381 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
382 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
385 else if (!proc
->result
->attr
.proc_pointer
)
387 gfc_error ("Function result %qs at %L has no IMPLICIT type",
388 proc
->result
->name
, &proc
->result
->declared_at
);
389 proc
->result
->attr
.untyped
= 1;
395 /******************** Symbol attribute stuff *********************/
397 /* This is a generic conflict-checker. We do this to avoid having a
398 single conflict in two places. */
400 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402 #define conf_std(a, b, std) if (attr->a && attr->b)\
411 gfc_check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
413 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
414 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
415 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
416 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
417 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
418 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
419 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
420 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
421 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
422 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
423 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
424 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
425 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
426 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
427 *proc_pointer
= "PROCEDURE POINTER", *abstract
= "ABSTRACT",
428 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
429 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC", *automatic
= "AUTOMATIC",
430 *pdt_len
= "LEN", *pdt_kind
= "KIND";
431 static const char *threadprivate
= "THREADPRIVATE";
432 static const char *omp_declare_target
= "OMP DECLARE TARGET";
433 static const char *omp_declare_target_link
= "OMP DECLARE TARGET LINK";
434 static const char *oacc_declare_copyin
= "OACC DECLARE COPYIN";
435 static const char *oacc_declare_create
= "OACC DECLARE CREATE";
436 static const char *oacc_declare_deviceptr
= "OACC DECLARE DEVICEPTR";
437 static const char *oacc_declare_device_resident
=
438 "OACC DECLARE DEVICE_RESIDENT";
443 if (attr
->artificial
)
447 where
= &gfc_current_locus
;
449 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
453 standard
= GFC_STD_F2003
;
457 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
460 a2
= attr
->allocatable
? allocatable
: pointer
;
461 standard
= GFC_STD_F2003
;
465 /* Check for attributes not allowed in a BLOCK DATA. */
466 if (gfc_current_state () == COMP_BLOCK_DATA
)
470 if (attr
->in_namelist
)
472 if (attr
->allocatable
)
478 if (attr
->access
== ACCESS_PRIVATE
)
480 if (attr
->access
== ACCESS_PUBLIC
)
482 if (attr
->intent
!= INTENT_UNKNOWN
)
488 ("%s attribute not allowed in BLOCK DATA program unit at %L",
494 if (attr
->save
== SAVE_EXPLICIT
)
497 conf (in_common
, save
);
499 conf (automatic
, save
);
501 switch (attr
->flavor
)
509 a1
= gfc_code2string (flavors
, attr
->flavor
);
513 gfc_error ("Namelist group name at %L cannot have the "
514 "SAVE attribute", where
);
517 /* Conflicts between SAVE and PROCEDURE will be checked at
518 resolution stage, see "resolve_fl_procedure". */
525 /* The copying of procedure dummy arguments for module procedures in
526 a submodule occur whilst the current state is COMP_CONTAINS. It
527 is necessary, therefore, to let this through. */
528 if (name
&& attr
->dummy
529 && (attr
->function
|| attr
->subroutine
)
530 && gfc_current_state () == COMP_CONTAINS
531 && !(gfc_new_block
&& gfc_new_block
->abr_modproc_decl
))
532 gfc_error_now ("internal procedure %qs at %L conflicts with "
533 "DUMMY argument", name
, where
);
536 conf (dummy
, intrinsic
);
537 conf (dummy
, threadprivate
);
538 conf (dummy
, omp_declare_target
);
539 conf (dummy
, omp_declare_target_link
);
540 conf (pointer
, target
);
541 conf (pointer
, intrinsic
);
542 conf (pointer
, elemental
);
543 conf (pointer
, codimension
);
544 conf (allocatable
, elemental
);
546 conf (in_common
, automatic
);
547 conf (result
, automatic
);
548 conf (use_assoc
, automatic
);
549 conf (dummy
, automatic
);
551 conf (target
, external
);
552 conf (target
, intrinsic
);
554 if (!attr
->if_source
)
555 conf (external
, dimension
); /* See Fortran 95's R504. */
557 conf (external
, intrinsic
);
558 conf (entry
, intrinsic
);
559 conf (abstract
, intrinsic
);
561 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
562 conf (external
, subroutine
);
564 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
565 "Procedure pointer at %C"))
568 conf (allocatable
, pointer
);
569 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
570 conf_std (allocatable
, function
, GFC_STD_F2003
);
571 conf_std (allocatable
, result
, GFC_STD_F2003
);
572 conf (elemental
, recursive
);
574 conf (in_common
, dummy
);
575 conf (in_common
, allocatable
);
576 conf (in_common
, codimension
);
577 conf (in_common
, result
);
579 conf (in_equivalence
, use_assoc
);
580 conf (in_equivalence
, codimension
);
581 conf (in_equivalence
, dummy
);
582 conf (in_equivalence
, target
);
583 conf (in_equivalence
, pointer
);
584 conf (in_equivalence
, function
);
585 conf (in_equivalence
, result
);
586 conf (in_equivalence
, entry
);
587 conf (in_equivalence
, allocatable
);
588 conf (in_equivalence
, threadprivate
);
589 conf (in_equivalence
, omp_declare_target
);
590 conf (in_equivalence
, omp_declare_target_link
);
591 conf (in_equivalence
, oacc_declare_create
);
592 conf (in_equivalence
, oacc_declare_copyin
);
593 conf (in_equivalence
, oacc_declare_deviceptr
);
594 conf (in_equivalence
, oacc_declare_device_resident
);
595 conf (in_equivalence
, is_bind_c
);
597 conf (dummy
, result
);
598 conf (entry
, result
);
599 conf (generic
, result
);
600 conf (generic
, omp_declare_target
);
601 conf (generic
, omp_declare_target_link
);
603 conf (function
, subroutine
);
605 if (!function
&& !subroutine
)
606 conf (is_bind_c
, dummy
);
608 conf (is_bind_c
, cray_pointer
);
609 conf (is_bind_c
, cray_pointee
);
610 conf (is_bind_c
, codimension
);
611 conf (is_bind_c
, allocatable
);
612 conf (is_bind_c
, elemental
);
614 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
615 Parameter conflict caught below. Also, value cannot be specified
616 for a dummy procedure. */
618 /* Cray pointer/pointee conflicts. */
619 conf (cray_pointer
, cray_pointee
);
620 conf (cray_pointer
, dimension
);
621 conf (cray_pointer
, codimension
);
622 conf (cray_pointer
, contiguous
);
623 conf (cray_pointer
, pointer
);
624 conf (cray_pointer
, target
);
625 conf (cray_pointer
, allocatable
);
626 conf (cray_pointer
, external
);
627 conf (cray_pointer
, intrinsic
);
628 conf (cray_pointer
, in_namelist
);
629 conf (cray_pointer
, function
);
630 conf (cray_pointer
, subroutine
);
631 conf (cray_pointer
, entry
);
633 conf (cray_pointee
, allocatable
);
634 conf (cray_pointee
, contiguous
);
635 conf (cray_pointee
, codimension
);
636 conf (cray_pointee
, intent
);
637 conf (cray_pointee
, optional
);
638 conf (cray_pointee
, dummy
);
639 conf (cray_pointee
, target
);
640 conf (cray_pointee
, intrinsic
);
641 conf (cray_pointee
, pointer
);
642 conf (cray_pointee
, entry
);
643 conf (cray_pointee
, in_common
);
644 conf (cray_pointee
, in_equivalence
);
645 conf (cray_pointee
, threadprivate
);
646 conf (cray_pointee
, omp_declare_target
);
647 conf (cray_pointee
, omp_declare_target_link
);
648 conf (cray_pointee
, oacc_declare_create
);
649 conf (cray_pointee
, oacc_declare_copyin
);
650 conf (cray_pointee
, oacc_declare_deviceptr
);
651 conf (cray_pointee
, oacc_declare_device_resident
);
654 conf (data
, function
);
656 conf (data
, allocatable
);
658 conf (value
, pointer
)
659 conf (value
, allocatable
)
660 conf (value
, subroutine
)
661 conf (value
, function
)
662 conf (value
, volatile_
)
663 conf (value
, dimension
)
664 conf (value
, codimension
)
665 conf (value
, external
)
667 conf (codimension
, result
)
670 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
673 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
677 conf (is_protected
, intrinsic
)
678 conf (is_protected
, in_common
)
680 conf (asynchronous
, intrinsic
)
681 conf (asynchronous
, external
)
683 conf (volatile_
, intrinsic
)
684 conf (volatile_
, external
)
686 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
693 conf (procedure
, allocatable
)
694 conf (procedure
, dimension
)
695 conf (procedure
, codimension
)
696 conf (procedure
, intrinsic
)
697 conf (procedure
, target
)
698 conf (procedure
, value
)
699 conf (procedure
, volatile_
)
700 conf (procedure
, asynchronous
)
701 conf (procedure
, entry
)
703 conf (proc_pointer
, abstract
)
704 conf (proc_pointer
, omp_declare_target
)
705 conf (proc_pointer
, omp_declare_target_link
)
707 conf (entry
, omp_declare_target
)
708 conf (entry
, omp_declare_target_link
)
709 conf (entry
, oacc_declare_create
)
710 conf (entry
, oacc_declare_copyin
)
711 conf (entry
, oacc_declare_deviceptr
)
712 conf (entry
, oacc_declare_device_resident
)
714 conf (pdt_kind
, allocatable
)
715 conf (pdt_kind
, pointer
)
716 conf (pdt_kind
, dimension
)
717 conf (pdt_kind
, codimension
)
719 conf (pdt_len
, allocatable
)
720 conf (pdt_len
, pointer
)
721 conf (pdt_len
, dimension
)
722 conf (pdt_len
, codimension
)
724 if (attr
->access
== ACCESS_PRIVATE
)
731 a1
= gfc_code2string (flavors
, attr
->flavor
);
733 if (attr
->in_namelist
734 && attr
->flavor
!= FL_VARIABLE
735 && attr
->flavor
!= FL_PROCEDURE
736 && attr
->flavor
!= FL_UNKNOWN
)
742 switch (attr
->flavor
)
752 conf2 (asynchronous
);
755 conf2 (is_protected
);
765 conf2 (threadprivate
);
766 conf2 (omp_declare_target
);
767 conf2 (omp_declare_target_link
);
768 conf2 (oacc_declare_create
);
769 conf2 (oacc_declare_copyin
);
770 conf2 (oacc_declare_deviceptr
);
771 conf2 (oacc_declare_device_resident
);
773 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
775 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
776 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
783 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
797 /* Conflicts with INTENT, SAVE and RESULT will be checked
798 at resolution stage, see "resolve_fl_procedure". */
800 if (attr
->subroutine
)
806 conf2 (asynchronous
);
811 if (!attr
->proc_pointer
)
812 conf2 (threadprivate
);
815 /* Procedure pointers in COMMON blocks are allowed in F03,
816 * but forbidden per F08:C5100. */
817 if (!attr
->proc_pointer
|| (gfc_option
.allow_std
& GFC_STD_F2008
))
820 conf2 (omp_declare_target_link
);
824 case PROC_ST_FUNCTION
:
835 conf2 (threadprivate
);
855 conf2 (threadprivate
);
857 conf2 (omp_declare_target
);
858 conf2 (omp_declare_target_link
);
859 conf2 (oacc_declare_create
);
860 conf2 (oacc_declare_copyin
);
861 conf2 (oacc_declare_deviceptr
);
862 conf2 (oacc_declare_device_resident
);
864 if (attr
->intent
!= INTENT_UNKNOWN
)
881 conf2 (is_protected
);
887 conf2 (asynchronous
);
888 conf2 (threadprivate
);
904 gfc_error ("%s attribute conflicts with %s attribute at %L",
907 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
908 a1
, a2
, name
, where
);
915 return gfc_notify_std (standard
, "%s attribute conflicts "
916 "with %s attribute at %L", a1
, a2
,
921 return gfc_notify_std (standard
, "%s attribute conflicts "
922 "with %s attribute in %qs at %L",
923 a1
, a2
, name
, where
);
932 /* Mark a symbol as referenced. */
935 gfc_set_sym_referenced (gfc_symbol
*sym
)
938 if (sym
->attr
.referenced
)
941 sym
->attr
.referenced
= 1;
943 /* Remember which order dummy variables are accessed in. */
945 sym
->dummy_order
= next_dummy_order
++;
949 /* Common subroutine called by attribute changing subroutines in order
950 to prevent them from changing a symbol that has been
951 use-associated. Returns zero if it is OK to change the symbol,
955 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
958 if (attr
->use_assoc
== 0)
962 where
= &gfc_current_locus
;
965 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
968 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
975 /* Generate an error because of a duplicate attribute. */
978 duplicate_attr (const char *attr
, locus
*where
)
982 where
= &gfc_current_locus
;
984 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
989 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
990 locus
*where ATTRIBUTE_UNUSED
)
992 attr
->ext_attr
|= 1 << ext_attr
;
997 /* Called from decl.c (attr_decl1) to check attributes, when declared
1001 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
1003 if (check_used (attr
, NULL
, where
))
1006 return gfc_check_conflict (attr
, NULL
, where
);
1011 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
1014 if (check_used (attr
, NULL
, where
))
1017 if (attr
->allocatable
&& ! gfc_submodule_procedure(attr
))
1019 duplicate_attr ("ALLOCATABLE", where
);
1023 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1024 && !gfc_find_state (COMP_INTERFACE
))
1026 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1031 attr
->allocatable
= 1;
1032 return gfc_check_conflict (attr
, NULL
, where
);
1037 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1039 if (check_used (attr
, name
, where
))
1042 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
1043 "Duplicate AUTOMATIC attribute specified at %L", where
))
1046 attr
->automatic
= 1;
1047 return gfc_check_conflict (attr
, name
, where
);
1052 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1055 if (check_used (attr
, name
, where
))
1058 if (attr
->codimension
)
1060 duplicate_attr ("CODIMENSION", where
);
1064 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1065 && !gfc_find_state (COMP_INTERFACE
))
1067 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1068 "at %L", name
, where
);
1072 attr
->codimension
= 1;
1073 return gfc_check_conflict (attr
, name
, where
);
1078 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1081 if (check_used (attr
, name
, where
))
1084 if (attr
->dimension
&& ! gfc_submodule_procedure(attr
))
1086 duplicate_attr ("DIMENSION", where
);
1090 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1091 && !gfc_find_state (COMP_INTERFACE
))
1093 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1094 "at %L", name
, where
);
1098 attr
->dimension
= 1;
1099 return gfc_check_conflict (attr
, name
, where
);
1104 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1107 if (check_used (attr
, name
, where
))
1110 attr
->contiguous
= 1;
1111 return gfc_check_conflict (attr
, name
, where
);
1116 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1119 if (check_used (attr
, NULL
, where
))
1124 duplicate_attr ("EXTERNAL", where
);
1128 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1131 attr
->proc_pointer
= 1;
1136 return gfc_check_conflict (attr
, NULL
, where
);
1141 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1144 if (check_used (attr
, NULL
, where
))
1147 if (attr
->intrinsic
)
1149 duplicate_attr ("INTRINSIC", where
);
1153 attr
->intrinsic
= 1;
1155 return gfc_check_conflict (attr
, NULL
, where
);
1160 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1163 if (check_used (attr
, NULL
, where
))
1168 duplicate_attr ("OPTIONAL", where
);
1173 return gfc_check_conflict (attr
, NULL
, where
);
1177 gfc_add_kind (symbol_attribute
*attr
, locus
*where
)
1181 duplicate_attr ("KIND", where
);
1186 return gfc_check_conflict (attr
, NULL
, where
);
1190 gfc_add_len (symbol_attribute
*attr
, locus
*where
)
1194 duplicate_attr ("LEN", where
);
1199 return gfc_check_conflict (attr
, NULL
, where
);
1204 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1207 if (check_used (attr
, NULL
, where
))
1210 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1211 && !gfc_find_state (COMP_INTERFACE
))
1212 && ! gfc_submodule_procedure(attr
))
1214 duplicate_attr ("POINTER", where
);
1218 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1219 || (attr
->if_source
== IFSRC_IFBODY
1220 && !gfc_find_state (COMP_INTERFACE
)))
1221 attr
->proc_pointer
= 1;
1225 return gfc_check_conflict (attr
, NULL
, where
);
1230 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1233 if (check_used (attr
, NULL
, where
))
1236 attr
->cray_pointer
= 1;
1237 return gfc_check_conflict (attr
, NULL
, where
);
1242 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1245 if (check_used (attr
, NULL
, where
))
1248 if (attr
->cray_pointee
)
1250 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1251 " statements", where
);
1255 attr
->cray_pointee
= 1;
1256 return gfc_check_conflict (attr
, NULL
, where
);
1261 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1263 if (check_used (attr
, name
, where
))
1266 if (attr
->is_protected
)
1268 if (!gfc_notify_std (GFC_STD_LEGACY
,
1269 "Duplicate PROTECTED attribute specified at %L",
1274 attr
->is_protected
= 1;
1275 return gfc_check_conflict (attr
, name
, where
);
1280 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1283 if (check_used (attr
, name
, where
))
1287 return gfc_check_conflict (attr
, name
, where
);
1292 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1296 if (check_used (attr
, name
, where
))
1299 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1302 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1307 if (s
== SAVE_EXPLICIT
)
1308 gfc_unset_implicit_pure (NULL
);
1310 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
1311 && (flag_automatic
|| pedantic
))
1313 if (!gfc_notify_std (GFC_STD_LEGACY
,
1314 "Duplicate SAVE attribute specified at %L",
1320 return gfc_check_conflict (attr
, name
, where
);
1325 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1328 if (check_used (attr
, name
, where
))
1333 if (!gfc_notify_std (GFC_STD_LEGACY
,
1334 "Duplicate VALUE attribute specified at %L",
1340 return gfc_check_conflict (attr
, name
, where
);
1345 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1347 /* No check_used needed as 11.2.1 of the F2003 standard allows
1348 that the local identifier made accessible by a use statement can be
1349 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1351 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1352 if (!gfc_notify_std (GFC_STD_LEGACY
,
1353 "Duplicate VOLATILE attribute specified at %L",
1357 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1358 shall not appear in a pure subprogram.
1360 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1361 construct within a pure subprogram, shall not have the SAVE or
1362 VOLATILE attribute. */
1363 if (gfc_pure (NULL
))
1365 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1366 "PURE procedure", where
);
1371 attr
->volatile_
= 1;
1372 attr
->volatile_ns
= gfc_current_ns
;
1373 return gfc_check_conflict (attr
, name
, where
);
1378 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1380 /* No check_used needed as 11.2.1 of the F2003 standard allows
1381 that the local identifier made accessible by a use statement can be
1382 given a ASYNCHRONOUS attribute. */
1384 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1385 if (!gfc_notify_std (GFC_STD_LEGACY
,
1386 "Duplicate ASYNCHRONOUS attribute specified at %L",
1390 attr
->asynchronous
= 1;
1391 attr
->asynchronous_ns
= gfc_current_ns
;
1392 return gfc_check_conflict (attr
, name
, where
);
1397 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1400 if (check_used (attr
, name
, where
))
1403 if (attr
->threadprivate
)
1405 duplicate_attr ("THREADPRIVATE", where
);
1409 attr
->threadprivate
= 1;
1410 return gfc_check_conflict (attr
, name
, where
);
1415 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1419 if (check_used (attr
, name
, where
))
1422 if (attr
->omp_declare_target
)
1425 attr
->omp_declare_target
= 1;
1426 return gfc_check_conflict (attr
, name
, where
);
1431 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1435 if (check_used (attr
, name
, where
))
1438 if (attr
->omp_declare_target_link
)
1441 attr
->omp_declare_target_link
= 1;
1442 return gfc_check_conflict (attr
, name
, where
);
1447 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1450 if (check_used (attr
, name
, where
))
1453 if (attr
->oacc_declare_create
)
1456 attr
->oacc_declare_create
= 1;
1457 return gfc_check_conflict (attr
, name
, where
);
1462 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1465 if (check_used (attr
, name
, where
))
1468 if (attr
->oacc_declare_copyin
)
1471 attr
->oacc_declare_copyin
= 1;
1472 return gfc_check_conflict (attr
, name
, where
);
1477 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1480 if (check_used (attr
, name
, where
))
1483 if (attr
->oacc_declare_deviceptr
)
1486 attr
->oacc_declare_deviceptr
= 1;
1487 return gfc_check_conflict (attr
, name
, where
);
1492 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1495 if (check_used (attr
, name
, where
))
1498 if (attr
->oacc_declare_device_resident
)
1501 attr
->oacc_declare_device_resident
= 1;
1502 return gfc_check_conflict (attr
, name
, where
);
1507 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1510 if (check_used (attr
, NULL
, where
))
1515 duplicate_attr ("TARGET", where
);
1520 return gfc_check_conflict (attr
, NULL
, where
);
1525 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1528 if (check_used (attr
, name
, where
))
1531 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1533 return gfc_check_conflict (attr
, name
, where
);
1538 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1541 if (check_used (attr
, name
, where
))
1544 /* Duplicate attribute already checked for. */
1545 attr
->in_common
= 1;
1546 return gfc_check_conflict (attr
, name
, where
);
1551 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1554 /* Duplicate attribute already checked for. */
1555 attr
->in_equivalence
= 1;
1556 if (!gfc_check_conflict (attr
, name
, where
))
1559 if (attr
->flavor
== FL_VARIABLE
)
1562 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1567 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1570 if (check_used (attr
, name
, where
))
1574 return gfc_check_conflict (attr
, name
, where
);
1579 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1582 attr
->in_namelist
= 1;
1583 return gfc_check_conflict (attr
, name
, where
);
1588 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1591 if (check_used (attr
, name
, where
))
1595 return gfc_check_conflict (attr
, name
, where
);
1600 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1603 if (check_used (attr
, NULL
, where
))
1606 if (attr
->elemental
)
1608 duplicate_attr ("ELEMENTAL", where
);
1612 attr
->elemental
= 1;
1613 return gfc_check_conflict (attr
, NULL
, where
);
1618 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1621 if (check_used (attr
, NULL
, where
))
1626 duplicate_attr ("PURE", where
);
1631 return gfc_check_conflict (attr
, NULL
, where
);
1636 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1639 if (check_used (attr
, NULL
, where
))
1642 if (attr
->recursive
)
1644 duplicate_attr ("RECURSIVE", where
);
1648 attr
->recursive
= 1;
1649 return gfc_check_conflict (attr
, NULL
, where
);
1654 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1657 if (check_used (attr
, name
, where
))
1662 duplicate_attr ("ENTRY", where
);
1667 return gfc_check_conflict (attr
, name
, where
);
1672 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1675 if (attr
->flavor
!= FL_PROCEDURE
1676 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1680 return gfc_check_conflict (attr
, name
, where
);
1685 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1688 if (attr
->flavor
!= FL_PROCEDURE
1689 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1692 attr
->subroutine
= 1;
1694 /* If we are looking at a BLOCK DATA statement and we encounter a
1695 name with a leading underscore (which must be
1696 compiler-generated), do not check. See PR 84394. */
1698 if (name
&& *name
!= '_' && gfc_current_state () != COMP_BLOCK_DATA
)
1699 return gfc_check_conflict (attr
, name
, where
);
1706 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1709 if (attr
->flavor
!= FL_PROCEDURE
1710 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1714 return gfc_check_conflict (attr
, name
, where
);
1719 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1722 if (check_used (attr
, NULL
, where
))
1725 if (attr
->flavor
!= FL_PROCEDURE
1726 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1729 if (attr
->procedure
)
1731 duplicate_attr ("PROCEDURE", where
);
1735 attr
->procedure
= 1;
1737 return gfc_check_conflict (attr
, NULL
, where
);
1742 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1746 duplicate_attr ("ABSTRACT", where
);
1752 return gfc_check_conflict (attr
, NULL
, where
);
1756 /* Flavors are special because some flavors are not what Fortran
1757 considers attributes and can be reaffirmed multiple times. */
1760 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1764 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1765 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1766 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1769 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1772 /* Copying a procedure dummy argument for a module procedure in a
1773 submodule results in the flavor being copied and would result in
1774 an error without this. */
1775 if (gfc_new_block
&& gfc_new_block
->abr_modproc_decl
1776 && attr
->flavor
== f
&& f
== FL_PROCEDURE
)
1779 if (attr
->flavor
!= FL_UNKNOWN
)
1782 where
= &gfc_current_locus
;
1785 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1786 gfc_code2string (flavors
, attr
->flavor
), name
,
1787 gfc_code2string (flavors
, f
), where
);
1789 gfc_error ("%s attribute conflicts with %s attribute at %L",
1790 gfc_code2string (flavors
, attr
->flavor
),
1791 gfc_code2string (flavors
, f
), where
);
1798 return gfc_check_conflict (attr
, name
, where
);
1803 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1804 const char *name
, locus
*where
)
1807 if (check_used (attr
, name
, where
))
1810 if (attr
->flavor
!= FL_PROCEDURE
1811 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1815 where
= &gfc_current_locus
;
1817 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
1818 && attr
->access
== ACCESS_UNKNOWN
)
1820 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1821 && !gfc_notification_std (GFC_STD_F2008
))
1822 gfc_error ("%s procedure at %L is already declared as %s "
1823 "procedure. \nF2008: A pointer function assignment "
1824 "is ambiguous if it is the first executable statement "
1825 "after the specification block. Please add any other "
1826 "kind of executable statement before it. FIXME",
1827 gfc_code2string (procedures
, t
), where
,
1828 gfc_code2string (procedures
, attr
->proc
));
1830 gfc_error ("%s procedure at %L is already declared as %s "
1831 "procedure", gfc_code2string (procedures
, t
), where
,
1832 gfc_code2string (procedures
, attr
->proc
));
1839 /* Statement functions are always scalar and functions. */
1840 if (t
== PROC_ST_FUNCTION
1841 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1842 || attr
->dimension
))
1845 return gfc_check_conflict (attr
, name
, where
);
1850 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1853 if (check_used (attr
, NULL
, where
))
1856 if (attr
->intent
== INTENT_UNKNOWN
)
1858 attr
->intent
= intent
;
1859 return gfc_check_conflict (attr
, NULL
, where
);
1863 where
= &gfc_current_locus
;
1865 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1866 gfc_intent_string (attr
->intent
),
1867 gfc_intent_string (intent
), where
);
1873 /* No checks for use-association in public and private statements. */
1876 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1877 const char *name
, locus
*where
)
1880 if (attr
->access
== ACCESS_UNKNOWN
1881 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1883 attr
->access
= access
;
1884 return gfc_check_conflict (attr
, name
, where
);
1888 where
= &gfc_current_locus
;
1889 gfc_error ("ACCESS specification at %L was already specified", where
);
1895 /* Set the is_bind_c field for the given symbol_attribute. */
1898 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1899 int is_proc_lang_bind_spec
)
1902 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1903 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1904 "variables or common blocks", where
);
1905 else if (attr
->is_bind_c
)
1906 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1908 attr
->is_bind_c
= 1;
1911 where
= &gfc_current_locus
;
1913 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1916 return gfc_check_conflict (attr
, name
, where
);
1920 /* Set the extension field for the given symbol_attribute. */
1923 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1926 where
= &gfc_current_locus
;
1928 if (attr
->extension
)
1929 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1931 attr
->extension
= 1;
1933 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1941 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1942 gfc_formal_arglist
* formal
, locus
*where
)
1944 if (check_used (&sym
->attr
, sym
->name
, where
))
1947 /* Skip the following checks in the case of a module_procedures in a
1948 submodule since they will manifestly fail. */
1949 if (sym
->attr
.module_procedure
== 1
1950 && source
== IFSRC_DECL
)
1954 where
= &gfc_current_locus
;
1956 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1957 && sym
->attr
.if_source
!= IFSRC_DECL
)
1959 gfc_error ("Symbol %qs at %L already has an explicit interface",
1964 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1966 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1967 "body", sym
->name
, where
);
1972 sym
->formal
= formal
;
1973 sym
->attr
.if_source
= source
;
1979 /* Add a type to a symbol. */
1982 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1988 where
= &gfc_current_locus
;
1991 type
= sym
->result
->ts
.type
;
1993 type
= sym
->ts
.type
;
1995 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1996 type
= sym
->ns
->proc_name
->ts
.type
;
1998 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1999 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
2000 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
2001 && !sym
->attr
.module_procedure
)
2003 if (sym
->attr
.use_assoc
)
2004 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2005 "use-associated at %L", sym
->name
, where
, sym
->module
,
2007 else if (sym
->attr
.function
&& sym
->attr
.result
)
2008 gfc_error ("Symbol %qs at %L already has basic type of %s",
2009 sym
->ns
->proc_name
->name
, where
, gfc_basic_typename (type
));
2011 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
2012 where
, gfc_basic_typename (type
));
2016 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
2018 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2019 sym
->name
, where
, gfc_basic_typename (ts
->type
));
2023 flavor
= sym
->attr
.flavor
;
2025 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
2026 || flavor
== FL_LABEL
2027 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
2028 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
2030 gfc_error ("Symbol %qs at %L cannot have a type",
2031 sym
->ns
->proc_name
? sym
->ns
->proc_name
->name
: sym
->name
,
2041 /* Clears all attributes. */
2044 gfc_clear_attr (symbol_attribute
*attr
)
2046 memset (attr
, 0, sizeof (symbol_attribute
));
2050 /* Check for missing attributes in the new symbol. Currently does
2051 nothing, but it's not clear that it is unnecessary yet. */
2054 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2055 locus
*where ATTRIBUTE_UNUSED
)
2062 /* Copy an attribute to a symbol attribute, bit by bit. Some
2063 attributes have a lot of side-effects but cannot be present given
2064 where we are called from, so we ignore some bits. */
2067 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2069 int is_proc_lang_bind_spec
;
2071 /* In line with the other attributes, we only add bits but do not remove
2072 them; cf. also PR 41034. */
2073 dest
->ext_attr
|= src
->ext_attr
;
2075 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2078 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2080 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2082 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2084 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2086 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2088 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2090 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2092 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2094 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2096 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2098 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2100 if (src
->threadprivate
2101 && !gfc_add_threadprivate (dest
, NULL
, where
))
2103 if (src
->omp_declare_target
2104 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2106 if (src
->omp_declare_target_link
2107 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2109 if (src
->oacc_declare_create
2110 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2112 if (src
->oacc_declare_copyin
2113 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2115 if (src
->oacc_declare_deviceptr
2116 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2118 if (src
->oacc_declare_device_resident
2119 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2121 if (src
->target
&& !gfc_add_target (dest
, where
))
2123 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2125 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2130 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2133 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2136 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2138 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2140 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2143 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2145 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2147 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2149 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2152 if (src
->flavor
!= FL_UNKNOWN
2153 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2156 if (src
->intent
!= INTENT_UNKNOWN
2157 && !gfc_add_intent (dest
, src
->intent
, where
))
2160 if (src
->access
!= ACCESS_UNKNOWN
2161 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2164 if (!gfc_missing_attr (dest
, where
))
2167 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2169 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2172 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2174 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2177 if (src
->is_c_interop
)
2178 dest
->is_c_interop
= 1;
2182 if (src
->external
&& !gfc_add_external (dest
, where
))
2184 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2186 if (src
->proc_pointer
)
2187 dest
->proc_pointer
= 1;
2196 /* A function to generate a dummy argument symbol using that from the
2197 interface declaration. Can be used for the result symbol as well if
2201 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2205 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2209 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2212 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2213 &gfc_current_locus
))
2216 if ((*dsym
)->attr
.dimension
)
2217 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2219 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2221 if ((*dsym
) != NULL
&& !result
2222 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2223 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2225 else if ((*dsym
) != NULL
&& result
2226 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2227 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2234 /************** Component name management ************/
2236 /* Component names of a derived type form their own little namespaces
2237 that are separate from all other spaces. The space is composed of
2238 a singly linked list of gfc_component structures whose head is
2239 located in the parent symbol. */
2242 /* Add a component name to a symbol. The call fails if the name is
2243 already present. On success, the component pointer is modified to
2244 point to the additional component structure. */
2247 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2248 gfc_component
**component
)
2250 gfc_component
*p
, *tail
;
2252 /* Check for existing components with the same name, but not for union
2253 components or containers. Unions and maps are anonymous so they have
2254 unique internal names which will never conflict.
2255 Don't use gfc_find_component here because it calls gfc_use_derived,
2256 but the derived type may not be fully defined yet. */
2259 for (p
= sym
->components
; p
; p
= p
->next
)
2261 if (strcmp (p
->name
, name
) == 0)
2263 gfc_error ("Component %qs at %C already declared at %L",
2271 if (sym
->attr
.extension
2272 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2273 name
, true, true, NULL
))
2275 gfc_error ("Component %qs at %C already in the parent type "
2276 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2280 /* Allocate a new component. */
2281 p
= gfc_get_component ();
2284 sym
->components
= p
;
2288 p
->name
= gfc_get_string ("%s", name
);
2289 p
->loc
= gfc_current_locus
;
2290 p
->ts
.type
= BT_UNKNOWN
;
2297 /* Recursive function to switch derived types of all symbol in a
2301 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2309 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2310 sym
->ts
.u
.derived
= to
;
2312 switch_types (st
->left
, from
, to
);
2313 switch_types (st
->right
, from
, to
);
2317 /* This subroutine is called when a derived type is used in order to
2318 make the final determination about which version to use. The
2319 standard requires that a type be defined before it is 'used', but
2320 such types can appear in IMPLICIT statements before the actual
2321 definition. 'Using' in this context means declaring a variable to
2322 be that type or using the type constructor.
2324 If a type is used and the components haven't been defined, then we
2325 have to have a derived type in a parent unit. We find the node in
2326 the other namespace and point the symtree node in this namespace to
2327 that node. Further reference to this name point to the correct
2328 node. If we can't find the node in a parent namespace, then we have
2331 This subroutine takes a pointer to a symbol node and returns a
2332 pointer to the translated node or NULL for an error. Usually there
2333 is no translation and we return the node we were passed. */
2336 gfc_use_derived (gfc_symbol
*sym
)
2346 if (sym
->attr
.unlimited_polymorphic
)
2349 if (sym
->attr
.generic
)
2350 sym
= gfc_find_dt_in_generic (sym
);
2352 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2353 return sym
; /* Already defined. */
2355 if (sym
->ns
->parent
== NULL
)
2358 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2360 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2364 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2367 /* Get rid of symbol sym, translating all references to s. */
2368 for (i
= 0; i
< GFC_LETTERS
; i
++)
2370 t
= &sym
->ns
->default_type
[i
];
2371 if (t
->u
.derived
== sym
)
2375 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2380 /* Unlink from list of modified symbols. */
2381 gfc_commit_symbol (sym
);
2383 switch_types (sym
->ns
->sym_root
, sym
, s
);
2385 /* TODO: Also have to replace sym -> s in other lists like
2386 namelists, common lists and interface lists. */
2387 gfc_free_symbol (sym
);
2392 gfc_error ("Derived type %qs at %C is being used before it is defined",
2398 /* Find the component with the given name in the union type symbol.
2399 If ref is not NULL it will be set to the chain of components through which
2400 the component can actually be accessed. This is necessary for unions because
2401 intermediate structures may be maps, nested structures, or other unions,
2402 all of which may (or must) be 'anonymous' to user code. */
2404 static gfc_component
*
2405 find_union_component (gfc_symbol
*un
, const char *name
,
2406 bool noaccess
, gfc_ref
**ref
)
2408 gfc_component
*m
, *check
;
2409 gfc_ref
*sref
, *tmp
;
2411 for (m
= un
->components
; m
; m
= m
->next
)
2413 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2417 /* Found component somewhere in m; chain the refs together. */
2421 sref
= gfc_get_ref ();
2422 sref
->type
= REF_COMPONENT
;
2423 sref
->u
.c
.component
= m
;
2424 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2429 /* Other checks (such as access) were done in the recursive calls. */
2436 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2437 the number of total candidates in CANDIDATES_LEN. */
2440 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2442 size_t &candidates_len
)
2444 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2445 vec_push (candidates
, candidates_len
, p
->name
);
2449 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2452 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2454 char **candidates
= NULL
;
2455 size_t candidates_len
= 0;
2456 lookup_component_fuzzy_find_candidates (component
, candidates
,
2458 return gfc_closest_fuzzy_match (member
, candidates
);
2462 /* Given a derived type node and a component name, try to locate the
2463 component structure. Returns the NULL pointer if the component is
2464 not found or the components are private. If noaccess is set, no access
2465 checks are done. If silent is set, an error will not be generated if
2466 the component cannot be found or accessed.
2468 If ref is not NULL, *ref is set to represent the chain of components
2469 required to get to the ultimate component.
2471 If the component is simply a direct subcomponent, or is inherited from a
2472 parent derived type in the given derived type, this is a single ref with its
2473 component set to the returned component.
2475 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2476 when the component is found through an implicit chain of nested union and
2477 map components. Unions and maps are "anonymous" substructures in FORTRAN
2478 which cannot be explicitly referenced, but the reference chain must be
2479 considered as in C for backend translation to correctly compute layouts.
2480 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2483 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2484 bool noaccess
, bool silent
, gfc_ref
**ref
)
2486 gfc_component
*p
, *check
;
2487 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2489 if (name
== NULL
|| sym
== NULL
)
2492 if (sym
->attr
.flavor
== FL_DERIVED
)
2493 sym
= gfc_use_derived (sym
);
2495 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2500 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2501 if (sym
->attr
.flavor
== FL_UNION
)
2502 return find_union_component (sym
, name
, noaccess
, ref
);
2504 if (ref
) *ref
= NULL
;
2505 for (p
= sym
->components
; p
; p
= p
->next
)
2507 /* Nest search into union's maps. */
2508 if (p
->ts
.type
== BT_UNION
)
2510 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2516 sref
= gfc_get_ref ();
2517 sref
->type
= REF_COMPONENT
;
2518 sref
->u
.c
.component
= p
;
2519 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2526 else if (strcmp (p
->name
, name
) == 0)
2532 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2534 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2535 if (p
->attr
.access
== ACCESS_PRIVATE
||
2536 (p
->attr
.access
!= ACCESS_PUBLIC
2537 && sym
->component_access
== ACCESS_PRIVATE
2538 && !is_parent_comp
))
2541 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2548 && sym
->attr
.extension
2549 && sym
->components
->ts
.type
== BT_DERIVED
)
2551 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2552 noaccess
, silent
, ref
);
2553 /* Do not overwrite the error. */
2558 if (p
== NULL
&& !silent
)
2560 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2562 gfc_error ("%qs at %C is not a member of the %qs structure"
2563 "; did you mean %qs?",
2564 name
, sym
->name
, guessed
);
2566 gfc_error ("%qs at %C is not a member of the %qs structure",
2570 /* Component was found; build the ultimate component reference. */
2571 if (p
!= NULL
&& ref
)
2573 tmp
= gfc_get_ref ();
2574 tmp
->type
= REF_COMPONENT
;
2575 tmp
->u
.c
.component
= p
;
2577 /* Link the final component ref to the end of the chain of subrefs. */
2581 for (; sref
->next
; sref
= sref
->next
)
2593 /* Given a symbol, free all of the component structures and everything
2597 free_components (gfc_component
*p
)
2605 gfc_free_array_spec (p
->as
);
2606 gfc_free_expr (p
->initializer
);
2608 gfc_free_expr (p
->kind_expr
);
2610 gfc_free_actual_arglist (p
->param_list
);
2618 /******************** Statement label management ********************/
2620 /* Comparison function for statement labels, used for managing the
2624 compare_st_labels (void *a1
, void *b1
)
2626 int a
= ((gfc_st_label
*) a1
)->value
;
2627 int b
= ((gfc_st_label
*) b1
)->value
;
2633 /* Free a single gfc_st_label structure, making sure the tree is not
2634 messed up. This function is called only when some parse error
2638 gfc_free_st_label (gfc_st_label
*label
)
2644 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2646 if (label
->format
!= NULL
)
2647 gfc_free_expr (label
->format
);
2653 /* Free a whole tree of gfc_st_label structures. */
2656 free_st_labels (gfc_st_label
*label
)
2662 free_st_labels (label
->left
);
2663 free_st_labels (label
->right
);
2665 if (label
->format
!= NULL
)
2666 gfc_free_expr (label
->format
);
2671 /* Given a label number, search for and return a pointer to the label
2672 structure, creating it if it does not exist. */
2675 gfc_get_st_label (int labelno
)
2680 if (gfc_current_state () == COMP_DERIVED
)
2681 ns
= gfc_current_block ()->f2k_derived
;
2684 /* Find the namespace of the scoping unit:
2685 If we're in a BLOCK construct, jump to the parent namespace. */
2686 ns
= gfc_current_ns
;
2687 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2691 /* First see if the label is already in this namespace. */
2695 if (lp
->value
== labelno
)
2698 if (lp
->value
< labelno
)
2704 lp
= XCNEW (gfc_st_label
);
2706 lp
->value
= labelno
;
2707 lp
->defined
= ST_LABEL_UNKNOWN
;
2708 lp
->referenced
= ST_LABEL_UNKNOWN
;
2711 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2717 /* Called when a statement with a statement label is about to be
2718 accepted. We add the label to the list of the current namespace,
2719 making sure it hasn't been defined previously and referenced
2723 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2727 labelno
= lp
->value
;
2729 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2730 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2731 &lp
->where
, label_locus
);
2734 lp
->where
= *label_locus
;
2738 case ST_LABEL_FORMAT
:
2739 if (lp
->referenced
== ST_LABEL_TARGET
2740 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2741 gfc_error ("Label %d at %C already referenced as branch target",
2744 lp
->defined
= ST_LABEL_FORMAT
;
2748 case ST_LABEL_TARGET
:
2749 case ST_LABEL_DO_TARGET
:
2750 if (lp
->referenced
== ST_LABEL_FORMAT
)
2751 gfc_error ("Label %d at %C already referenced as a format label",
2756 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2757 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2758 "DO termination statement which is not END DO"
2759 " or CONTINUE with label %d at %C", labelno
))
2764 lp
->defined
= ST_LABEL_BAD_TARGET
;
2765 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2771 /* Reference a label. Given a label and its type, see if that
2772 reference is consistent with what is known about that label,
2773 updating the unknown state. Returns false if something goes
2777 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2779 gfc_sl_type label_type
;
2786 labelno
= lp
->value
;
2788 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2789 label_type
= lp
->defined
;
2792 label_type
= lp
->referenced
;
2793 lp
->where
= gfc_current_locus
;
2796 if (label_type
== ST_LABEL_FORMAT
2797 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2799 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2804 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2805 || label_type
== ST_LABEL_BAD_TARGET
)
2806 && type
== ST_LABEL_FORMAT
)
2808 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2813 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2814 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2815 "Shared DO termination label %d at %C", labelno
))
2818 if (type
== ST_LABEL_DO_TARGET
2819 && !gfc_notify_std (GFC_STD_F2018_OBS
, "Labeled DO statement "
2820 "at %L", &gfc_current_locus
))
2823 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2824 lp
->referenced
= type
;
2832 /************** Symbol table management subroutines ****************/
2834 /* Basic details: Fortran 95 requires a potentially unlimited number
2835 of distinct namespaces when compiling a program unit. This case
2836 occurs during a compilation of internal subprograms because all of
2837 the internal subprograms must be read before we can start
2838 generating code for the host.
2840 Given the tricky nature of the Fortran grammar, we must be able to
2841 undo changes made to a symbol table if the current interpretation
2842 of a statement is found to be incorrect. Whenever a symbol is
2843 looked up, we make a copy of it and link to it. All of these
2844 symbols are kept in a vector so that we can commit or
2845 undo the changes at a later time.
2847 A symtree may point to a symbol node outside of its namespace. In
2848 this case, that symbol has been used as a host associated variable
2849 at some previous time. */
2851 /* Allocate a new namespace structure. Copies the implicit types from
2852 PARENT if PARENT_TYPES is set. */
2855 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2862 ns
= XCNEW (gfc_namespace
);
2863 ns
->sym_root
= NULL
;
2864 ns
->uop_root
= NULL
;
2865 ns
->tb_sym_root
= NULL
;
2866 ns
->finalizers
= NULL
;
2867 ns
->default_access
= ACCESS_UNKNOWN
;
2868 ns
->parent
= parent
;
2870 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2872 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2873 ns
->tb_op
[in
] = NULL
;
2876 /* Initialize default implicit types. */
2877 for (i
= 'a'; i
<= 'z'; i
++)
2879 ns
->set_flag
[i
- 'a'] = 0;
2880 ts
= &ns
->default_type
[i
- 'a'];
2882 if (parent_types
&& ns
->parent
!= NULL
)
2884 /* Copy parent settings. */
2885 *ts
= ns
->parent
->default_type
[i
- 'a'];
2889 if (flag_implicit_none
!= 0)
2895 if ('i' <= i
&& i
<= 'n')
2897 ts
->type
= BT_INTEGER
;
2898 ts
->kind
= gfc_default_integer_kind
;
2903 ts
->kind
= gfc_default_real_kind
;
2913 /* Comparison function for symtree nodes. */
2916 compare_symtree (void *_st1
, void *_st2
)
2918 gfc_symtree
*st1
, *st2
;
2920 st1
= (gfc_symtree
*) _st1
;
2921 st2
= (gfc_symtree
*) _st2
;
2923 return strcmp (st1
->name
, st2
->name
);
2927 /* Allocate a new symtree node and associate it with the new symbol. */
2930 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2934 st
= XCNEW (gfc_symtree
);
2935 st
->name
= gfc_get_string ("%s", name
);
2937 gfc_insert_bbt (root
, st
, compare_symtree
);
2942 /* Delete a symbol from the tree. Does not free the symbol itself! */
2945 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2947 gfc_symtree st
, *st0
;
2950 /* Submodules are marked as mod.submod. When freeing a submodule
2951 symbol, the symtree only has "submod", so adjust that here. */
2953 p
= strrchr(name
, '.');
2959 st0
= gfc_find_symtree (*root
, p
);
2961 st
.name
= gfc_get_string ("%s", p
);
2962 gfc_delete_bbt (root
, &st
, compare_symtree
);
2968 /* Given a root symtree node and a name, try to find the symbol within
2969 the namespace. Returns NULL if the symbol is not found. */
2972 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2978 c
= strcmp (name
, st
->name
);
2982 st
= (c
< 0) ? st
->left
: st
->right
;
2989 /* Return a symtree node with a name that is guaranteed to be unique
2990 within the namespace and corresponds to an illegal fortran name. */
2993 gfc_get_unique_symtree (gfc_namespace
*ns
)
2995 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2996 static int serial
= 0;
2998 sprintf (name
, "@%d", serial
++);
2999 return gfc_new_symtree (&ns
->sym_root
, name
);
3003 /* Given a name find a user operator node, creating it if it doesn't
3004 exist. These are much simpler than symbols because they can't be
3005 ambiguous with one another. */
3008 gfc_get_uop (const char *name
)
3012 gfc_namespace
*ns
= gfc_current_ns
;
3016 st
= gfc_find_symtree (ns
->uop_root
, name
);
3020 st
= gfc_new_symtree (&ns
->uop_root
, name
);
3022 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
3023 uop
->name
= gfc_get_string ("%s", name
);
3024 uop
->access
= ACCESS_UNKNOWN
;
3031 /* Given a name find the user operator node. Returns NULL if it does
3035 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3040 ns
= gfc_current_ns
;
3042 st
= gfc_find_symtree (ns
->uop_root
, name
);
3043 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3047 /* Update a symbol's common_block field, and take care of the associated
3048 memory management. */
3051 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3053 if (sym
->common_block
== common_block
)
3056 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3058 sym
->common_block
->refs
--;
3059 if (sym
->common_block
->refs
== 0)
3060 free (sym
->common_block
);
3062 sym
->common_block
= common_block
;
3066 /* Remove a gfc_symbol structure and everything it points to. */
3069 gfc_free_symbol (gfc_symbol
*sym
)
3075 gfc_free_array_spec (sym
->as
);
3077 free_components (sym
->components
);
3079 gfc_free_expr (sym
->value
);
3081 gfc_free_namelist (sym
->namelist
);
3083 if (sym
->ns
!= sym
->formal_ns
)
3084 gfc_free_namespace (sym
->formal_ns
);
3086 if (!sym
->attr
.generic_copy
)
3087 gfc_free_interface (sym
->generic
);
3089 gfc_free_formal_arglist (sym
->formal
);
3091 gfc_free_namespace (sym
->f2k_derived
);
3093 set_symbol_common_block (sym
, NULL
);
3095 if (sym
->param_list
)
3096 gfc_free_actual_arglist (sym
->param_list
);
3102 /* Decrease the reference counter and free memory when we reach zero. */
3105 gfc_release_symbol (gfc_symbol
*sym
)
3110 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
3111 && (!sym
->attr
.entry
|| !sym
->module
))
3113 /* As formal_ns contains a reference to sym, delete formal_ns just
3114 before the deletion of sym. */
3115 gfc_namespace
*ns
= sym
->formal_ns
;
3116 sym
->formal_ns
= NULL
;
3117 gfc_free_namespace (ns
);
3124 gcc_assert (sym
->refs
== 0);
3125 gfc_free_symbol (sym
);
3129 /* Allocate and initialize a new symbol node. */
3132 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3136 p
= XCNEW (gfc_symbol
);
3138 gfc_clear_ts (&p
->ts
);
3139 gfc_clear_attr (&p
->attr
);
3141 p
->declared_at
= gfc_current_locus
;
3142 p
->name
= gfc_get_string ("%s", name
);
3148 /* Generate an error if a symbol is ambiguous, and set the error flag
3152 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3155 if (st
->n
.sym
->error
)
3158 if (st
->n
.sym
->module
)
3159 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3160 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3162 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3163 "from current program unit", name
, st
->n
.sym
->name
);
3165 st
->n
.sym
->error
= 1;
3169 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3170 selector on the stack. If yes, replace it by the corresponding temporary. */
3173 select_type_insert_tmp (gfc_symtree
**st
)
3175 gfc_select_type_stack
*stack
= select_type_stack
;
3176 for (; stack
; stack
= stack
->prev
)
3177 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3180 select_type_insert_tmp (st
);
3186 /* Look for a symtree in the current procedure -- that is, go up to
3187 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3190 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3194 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3198 if (!ns
->construct_entities
)
3207 /* Search for a symtree starting in the current namespace, resorting to
3208 any parent namespaces if requested by a nonzero parent_flag.
3209 Returns nonzero if the name is ambiguous. */
3212 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3213 gfc_symtree
**result
)
3218 ns
= gfc_current_ns
;
3222 st
= gfc_find_symtree (ns
->sym_root
, name
);
3225 select_type_insert_tmp (&st
);
3228 /* Ambiguous generic interfaces are permitted, as long
3229 as the specific interfaces are different. */
3230 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3232 ambiguous_symbol (name
, st
);
3242 /* Don't escape an interface block. */
3243 if (ns
&& !ns
->has_import_set
3244 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3251 if (gfc_current_state() == COMP_DERIVED
3252 && gfc_current_block ()->attr
.pdt_template
)
3254 gfc_symbol
*der
= gfc_current_block ();
3255 for (; der
; der
= gfc_get_derived_super_type (der
))
3257 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3259 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3274 /* Same, but returns the symbol instead. */
3277 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3278 gfc_symbol
**result
)
3283 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3288 *result
= st
->n
.sym
;
3294 /* Tells whether there is only one set of changes in the stack. */
3297 single_undo_checkpoint_p (void)
3299 if (latest_undo_chgset
== &default_undo_chgset_var
)
3301 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3306 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3311 /* Save symbol with the information necessary to back it out. */
3314 gfc_save_symbol_data (gfc_symbol
*sym
)
3319 if (!single_undo_checkpoint_p ())
3321 /* If there is more than one change set, look for the symbol in the
3322 current one. If it is found there, we can reuse it. */
3323 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3326 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3330 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3333 s
= XCNEW (gfc_symbol
);
3335 sym
->old_symbol
= s
;
3338 latest_undo_chgset
->syms
.safe_push (sym
);
3342 /* Given a name, find a symbol, or create it if it does not exist yet
3343 in the current namespace. If the symbol is found we make sure that
3346 The integer return code indicates
3348 1 The symbol name was ambiguous
3349 2 The name meant to be established was already host associated.
3351 So if the return value is nonzero, then an error was issued. */
3354 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3355 bool allow_subroutine
)
3360 /* This doesn't usually happen during resolution. */
3362 ns
= gfc_current_ns
;
3364 /* Try to find the symbol in ns. */
3365 st
= gfc_find_symtree (ns
->sym_root
, name
);
3367 if (st
== NULL
&& ns
->omp_udr_ns
)
3370 st
= gfc_find_symtree (ns
->sym_root
, name
);
3375 /* If not there, create a new symbol. */
3376 p
= gfc_new_symbol (name
, ns
);
3378 /* Add to the list of tentative symbols. */
3379 p
->old_symbol
= NULL
;
3382 latest_undo_chgset
->syms
.safe_push (p
);
3384 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3391 /* Make sure the existing symbol is OK. Ambiguous
3392 generic interfaces are permitted, as long as the
3393 specific interfaces are different. */
3394 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3396 ambiguous_symbol (name
, st
);
3401 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3402 && !(allow_subroutine
&& p
->attr
.subroutine
)
3403 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3404 && (ns
->has_import_set
|| p
->attr
.imported
)))
3406 /* Symbol is from another namespace. */
3407 gfc_error ("Symbol %qs at %C has already been host associated",
3414 /* Copy in case this symbol is changed. */
3415 gfc_save_symbol_data (p
);
3424 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3429 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3434 *result
= st
->n
.sym
;
3441 /* Subroutine that searches for a symbol, creating it if it doesn't
3442 exist, but tries to host-associate the symbol if possible. */
3445 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3450 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3454 gfc_save_symbol_data (st
->n
.sym
);
3459 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3469 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3474 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3479 i
= gfc_get_ha_sym_tree (name
, &st
);
3482 *result
= st
->n
.sym
;
3490 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3491 head->name as the common_root symtree's name might be mangled. */
3493 static gfc_symtree
*
3494 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3497 gfc_symtree
*result
;
3502 if (st
->n
.common
== head
)
3505 result
= find_common_symtree (st
->left
, head
);
3507 result
= find_common_symtree (st
->right
, head
);
3513 /* Restore previous state of symbol. Just copy simple stuff. */
3516 restore_old_symbol (gfc_symbol
*p
)
3521 old
= p
->old_symbol
;
3523 p
->ts
.type
= old
->ts
.type
;
3524 p
->ts
.kind
= old
->ts
.kind
;
3526 p
->attr
= old
->attr
;
3528 if (p
->value
!= old
->value
)
3530 gcc_checking_assert (old
->value
== NULL
);
3531 gfc_free_expr (p
->value
);
3535 if (p
->as
!= old
->as
)
3538 gfc_free_array_spec (p
->as
);
3542 p
->generic
= old
->generic
;
3543 p
->component_access
= old
->component_access
;
3545 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3547 gfc_free_namelist (p
->namelist
);
3552 if (p
->namelist_tail
!= old
->namelist_tail
)
3554 gfc_free_namelist (old
->namelist_tail
->next
);
3555 old
->namelist_tail
->next
= NULL
;
3559 p
->namelist_tail
= old
->namelist_tail
;
3561 if (p
->formal
!= old
->formal
)
3563 gfc_free_formal_arglist (p
->formal
);
3564 p
->formal
= old
->formal
;
3567 set_symbol_common_block (p
, old
->common_block
);
3568 p
->common_head
= old
->common_head
;
3570 p
->old_symbol
= old
->old_symbol
;
3575 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3576 the structure itself. */
3579 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3586 /* Given a change set pointer, free its target's contents and update it with
3587 the address of the previous change set. Note that only the contents are
3588 freed, not the target itself (the contents' container). It is not a problem
3589 as the latter will be a local variable usually. */
3592 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3594 free_undo_change_set_data (*cs
);
3599 static void free_old_symbol (gfc_symbol
*sym
);
3602 /* Merges the current change set into the previous one. The changes themselves
3603 are left untouched; only one checkpoint is forgotten. */
3606 gfc_drop_last_undo_checkpoint (void)
3611 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3613 /* No need to loop in this case. */
3614 if (s
->old_symbol
== NULL
)
3617 /* Remove the duplicate symbols. */
3618 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3621 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3623 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3624 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3625 shall contain from now on the backup symbol for S as it was
3626 at the checkpoint before. */
3627 if (s
->old_symbol
->gfc_new
)
3629 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3630 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3631 free_old_symbol (s
);
3634 restore_old_symbol (s
->old_symbol
);
3639 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3640 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3642 pop_undo_change_set (latest_undo_chgset
);
3646 /* Undoes all the changes made to symbols since the previous checkpoint.
3647 This subroutine is made simpler due to the fact that attributes are
3648 never removed once added. */
3651 gfc_restore_last_undo_checkpoint (void)
3656 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3658 /* Symbol in a common block was new. Or was old and just put in common */
3660 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3662 /* If the symbol was added to any common block, it
3663 needs to be removed to stop the resolver looking
3664 for a (possibly) dead symbol. */
3665 if (p
->common_block
->head
== p
&& !p
->common_next
)
3667 gfc_symtree st
, *st0
;
3668 st0
= find_common_symtree (p
->ns
->common_root
,
3672 st
.name
= st0
->name
;
3673 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3678 if (p
->common_block
->head
== p
)
3679 p
->common_block
->head
= p
->common_next
;
3682 gfc_symbol
*cparent
, *csym
;
3684 cparent
= p
->common_block
->head
;
3685 csym
= cparent
->common_next
;
3690 csym
= csym
->common_next
;
3693 gcc_assert(cparent
->common_next
== p
);
3694 cparent
->common_next
= csym
->common_next
;
3696 p
->common_next
= NULL
;
3700 /* The derived type is saved in the symtree with the first
3701 letter capitalized; the all lower-case version to the
3702 derived type contains its associated generic function. */
3703 if (gfc_fl_struct (p
->attr
.flavor
))
3704 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3706 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3708 gfc_release_symbol (p
);
3711 restore_old_symbol (p
);
3714 latest_undo_chgset
->syms
.truncate (0);
3715 latest_undo_chgset
->tbps
.truncate (0);
3717 if (!single_undo_checkpoint_p ())
3718 pop_undo_change_set (latest_undo_chgset
);
3722 /* Makes sure that there is only one set of changes; in other words we haven't
3723 forgotten to pair a call to gfc_new_checkpoint with a call to either
3724 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3727 enforce_single_undo_checkpoint (void)
3729 gcc_checking_assert (single_undo_checkpoint_p ());
3733 /* Undoes all the changes made to symbols in the current statement. */
3736 gfc_undo_symbols (void)
3738 enforce_single_undo_checkpoint ();
3739 gfc_restore_last_undo_checkpoint ();
3743 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3744 components of old_symbol that might need deallocation are the "allocatables"
3745 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3746 namelist_tail. In case these differ between old_symbol and sym, it's just
3747 because sym->namelist has gotten a few more items. */
3750 free_old_symbol (gfc_symbol
*sym
)
3753 if (sym
->old_symbol
== NULL
)
3756 if (sym
->old_symbol
->as
!= sym
->as
)
3757 gfc_free_array_spec (sym
->old_symbol
->as
);
3759 if (sym
->old_symbol
->value
!= sym
->value
)
3760 gfc_free_expr (sym
->old_symbol
->value
);
3762 if (sym
->old_symbol
->formal
!= sym
->formal
)
3763 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3765 free (sym
->old_symbol
);
3766 sym
->old_symbol
= NULL
;
3770 /* Makes the changes made in the current statement permanent-- gets
3771 rid of undo information. */
3774 gfc_commit_symbols (void)
3777 gfc_typebound_proc
*tbp
;
3780 enforce_single_undo_checkpoint ();
3782 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3786 free_old_symbol (p
);
3788 latest_undo_chgset
->syms
.truncate (0);
3790 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3792 latest_undo_chgset
->tbps
.truncate (0);
3796 /* Makes the changes made in one symbol permanent -- gets rid of undo
3800 gfc_commit_symbol (gfc_symbol
*sym
)
3805 enforce_single_undo_checkpoint ();
3807 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3810 latest_undo_chgset
->syms
.unordered_remove (i
);
3817 free_old_symbol (sym
);
3821 /* Recursively free trees containing type-bound procedures. */
3824 free_tb_tree (gfc_symtree
*t
)
3829 free_tb_tree (t
->left
);
3830 free_tb_tree (t
->right
);
3832 /* TODO: Free type-bound procedure structs themselves; probably needs some
3833 sort of ref-counting mechanism. */
3839 /* Recursive function that deletes an entire tree and all the common
3840 head structures it points to. */
3843 free_common_tree (gfc_symtree
* common_tree
)
3845 if (common_tree
== NULL
)
3848 free_common_tree (common_tree
->left
);
3849 free_common_tree (common_tree
->right
);
3855 /* Recursive function that deletes an entire tree and all the common
3856 head structures it points to. */
3859 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3861 if (omp_udr_tree
== NULL
)
3864 free_omp_udr_tree (omp_udr_tree
->left
);
3865 free_omp_udr_tree (omp_udr_tree
->right
);
3867 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3868 free (omp_udr_tree
);
3872 /* Recursive function that deletes an entire tree and all the user
3873 operator nodes that it contains. */
3876 free_uop_tree (gfc_symtree
*uop_tree
)
3878 if (uop_tree
== NULL
)
3881 free_uop_tree (uop_tree
->left
);
3882 free_uop_tree (uop_tree
->right
);
3884 gfc_free_interface (uop_tree
->n
.uop
->op
);
3885 free (uop_tree
->n
.uop
);
3890 /* Recursive function that deletes an entire tree and all the symbols
3891 that it contains. */
3894 free_sym_tree (gfc_symtree
*sym_tree
)
3896 if (sym_tree
== NULL
)
3899 free_sym_tree (sym_tree
->left
);
3900 free_sym_tree (sym_tree
->right
);
3902 gfc_release_symbol (sym_tree
->n
.sym
);
3907 /* Free the gfc_equiv_info's. */
3910 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3914 gfc_free_equiv_infos (s
->next
);
3919 /* Free the gfc_equiv_lists. */
3922 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3926 gfc_free_equiv_lists (l
->next
);
3927 gfc_free_equiv_infos (l
->equiv
);
3932 /* Free a finalizer procedure list. */
3935 gfc_free_finalizer (gfc_finalizer
* el
)
3939 gfc_release_symbol (el
->proc_sym
);
3945 gfc_free_finalizer_list (gfc_finalizer
* list
)
3949 gfc_finalizer
* current
= list
;
3951 gfc_free_finalizer (current
);
3956 /* Create a new gfc_charlen structure and add it to a namespace.
3957 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3960 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3964 cl
= gfc_get_charlen ();
3969 cl
->length
= gfc_copy_expr (old_cl
->length
);
3970 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3971 cl
->backend_decl
= old_cl
->backend_decl
;
3972 cl
->passed_length
= old_cl
->passed_length
;
3973 cl
->resolved
= old_cl
->resolved
;
3976 /* Put into namespace. */
3977 cl
->next
= ns
->cl_list
;
3984 /* Free the charlen list from cl to end (end is not freed).
3985 Free the whole list if end is NULL. */
3988 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3992 for (; cl
!= end
; cl
= cl2
)
3997 gfc_free_expr (cl
->length
);
4003 /* Free entry list structs. */
4006 free_entry_list (gfc_entry_list
*el
)
4008 gfc_entry_list
*next
;
4015 free_entry_list (next
);
4019 /* Free a namespace structure and everything below it. Interface
4020 lists associated with intrinsic operators are not freed. These are
4021 taken care of when a specific name is freed. */
4024 gfc_free_namespace (gfc_namespace
*ns
)
4026 gfc_namespace
*p
, *q
;
4028 gfc_was_finalized
*f
;
4037 gcc_assert (ns
->refs
== 0);
4039 gfc_free_statements (ns
->code
);
4041 free_sym_tree (ns
->sym_root
);
4042 free_uop_tree (ns
->uop_root
);
4043 free_common_tree (ns
->common_root
);
4044 free_omp_udr_tree (ns
->omp_udr_root
);
4045 free_tb_tree (ns
->tb_sym_root
);
4046 free_tb_tree (ns
->tb_uop_root
);
4047 gfc_free_finalizer_list (ns
->finalizers
);
4048 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4049 gfc_free_charlen (ns
->cl_list
, NULL
);
4050 free_st_labels (ns
->st_labels
);
4052 free_entry_list (ns
->entries
);
4053 gfc_free_equiv (ns
->equiv
);
4054 gfc_free_equiv_lists (ns
->equiv_lists
);
4055 gfc_free_use_stmts (ns
->use_stmts
);
4057 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4058 gfc_free_interface (ns
->op
[i
]);
4060 gfc_free_data (ns
->data
);
4062 /* Free all the expr + component combinations that have been
4064 f
= ns
->was_finalized
;
4067 gfc_was_finalized
* current
= f
;
4075 /* Recursively free any contained namespaces. */
4080 gfc_free_namespace (q
);
4086 gfc_symbol_init_2 (void)
4089 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4094 gfc_symbol_done_2 (void)
4096 if (gfc_current_ns
!= NULL
)
4098 /* free everything from the root. */
4099 while (gfc_current_ns
->parent
!= NULL
)
4100 gfc_current_ns
= gfc_current_ns
->parent
;
4101 gfc_free_namespace (gfc_current_ns
);
4102 gfc_current_ns
= NULL
;
4104 gfc_derived_types
= NULL
;
4106 enforce_single_undo_checkpoint ();
4107 free_undo_change_set_data (*latest_undo_chgset
);
4111 /* Count how many nodes a symtree has. */
4114 count_st_nodes (const gfc_symtree
*st
)
4120 nodes
= count_st_nodes (st
->left
);
4122 nodes
+= count_st_nodes (st
->right
);
4128 /* Convert symtree tree into symtree vector. */
4131 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4136 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4137 st_vec
[node_cntr
++] = st
;
4138 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4144 /* Traverse namespace. As the functions might modify the symtree, we store the
4145 symtree as a vector and operate on this vector. Note: We assume that
4146 sym_func or st_func never deletes nodes from the symtree - only adding is
4147 allowed. Additionally, newly added nodes are not traversed. */
4150 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4151 void (*sym_func
) (gfc_symbol
*))
4153 gfc_symtree
**st_vec
;
4154 unsigned nodes
, i
, node_cntr
;
4156 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4157 nodes
= count_st_nodes (st
);
4158 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4160 fill_st_vector (st
, st_vec
, node_cntr
);
4165 for (i
= 0; i
< nodes
; i
++)
4166 st_vec
[i
]->n
.sym
->mark
= 0;
4167 for (i
= 0; i
< nodes
; i
++)
4168 if (!st_vec
[i
]->n
.sym
->mark
)
4170 (*sym_func
) (st_vec
[i
]->n
.sym
);
4171 st_vec
[i
]->n
.sym
->mark
= 1;
4175 for (i
= 0; i
< nodes
; i
++)
4176 (*st_func
) (st_vec
[i
]);
4180 /* Recursively traverse the symtree nodes. */
4183 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4185 do_traverse_symtree (st
, st_func
, NULL
);
4189 /* Call a given function for all symbols in the namespace. We take
4190 care that each gfc_symbol node is called exactly once. */
4193 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4195 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4199 /* Return TRUE when name is the name of an intrinsic type. */
4202 gfc_is_intrinsic_typename (const char *name
)
4204 if (strcmp (name
, "integer") == 0
4205 || strcmp (name
, "real") == 0
4206 || strcmp (name
, "character") == 0
4207 || strcmp (name
, "logical") == 0
4208 || strcmp (name
, "complex") == 0
4209 || strcmp (name
, "doubleprecision") == 0
4210 || strcmp (name
, "doublecomplex") == 0)
4217 /* Return TRUE if the symbol is an automatic variable. */
4220 gfc_is_var_automatic (gfc_symbol
*sym
)
4222 /* Pointer and allocatable variables are never automatic. */
4223 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4225 /* Check for arrays with non-constant size. */
4226 if (sym
->attr
.dimension
&& sym
->as
4227 && !gfc_is_compile_time_shape (sym
->as
))
4229 /* Check for non-constant length character variables. */
4230 if (sym
->ts
.type
== BT_CHARACTER
4232 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4234 /* Variables with explicit AUTOMATIC attribute. */
4235 if (sym
->attr
.automatic
)
4241 /* Given a symbol, mark it as SAVEd if it is allowed. */
4244 save_symbol (gfc_symbol
*sym
)
4247 if (sym
->attr
.use_assoc
)
4250 if (sym
->attr
.in_common
4251 || sym
->attr
.in_equivalence
4254 || sym
->attr
.flavor
!= FL_VARIABLE
)
4256 /* Automatic objects are not saved. */
4257 if (gfc_is_var_automatic (sym
))
4259 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4263 /* Mark those symbols which can be SAVEd as such. */
4266 gfc_save_all (gfc_namespace
*ns
)
4268 gfc_traverse_ns (ns
, save_symbol
);
4272 /* Make sure that no changes to symbols are pending. */
4275 gfc_enforce_clean_symbol_state(void)
4277 enforce_single_undo_checkpoint ();
4278 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4282 /************** Global symbol handling ************/
4285 /* Search a tree for the global symbol. */
4288 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4297 c
= strcmp (name
, symbol
->name
);
4301 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4308 /* Case insensitive search a tree for the global symbol. */
4311 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4320 c
= strcasecmp (name
, symbol
->name
);
4324 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4331 /* Compare two global symbols. Used for managing the BB tree. */
4334 gsym_compare (void *_s1
, void *_s2
)
4336 gfc_gsymbol
*s1
, *s2
;
4338 s1
= (gfc_gsymbol
*) _s1
;
4339 s2
= (gfc_gsymbol
*) _s2
;
4340 return strcmp (s1
->name
, s2
->name
);
4344 /* Get a global symbol, creating it if it doesn't exist. */
4347 gfc_get_gsymbol (const char *name
, bool bind_c
)
4351 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4355 s
= XCNEW (gfc_gsymbol
);
4356 s
->type
= GSYM_UNKNOWN
;
4357 s
->name
= gfc_get_string ("%s", name
);
4360 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4366 gfc_traverse_gsymbol (gfc_gsymbol
*gsym
,
4367 void (*do_something
) (gfc_gsymbol
*, void *),
4371 gfc_traverse_gsymbol (gsym
->left
, do_something
, data
);
4373 (*do_something
) (gsym
, data
);
4376 gfc_traverse_gsymbol (gsym
->right
, do_something
, data
);
4380 get_iso_c_binding_dt (int sym_id
)
4382 gfc_symbol
*dt_list
= gfc_derived_types
;
4384 /* Loop through the derived types in the name list, searching for
4385 the desired symbol from iso_c_binding. Search the parent namespaces
4386 if necessary and requested to (parent_flag). */
4389 while (dt_list
->dt_next
!= gfc_derived_types
)
4391 if (dt_list
->from_intmod
!= INTMOD_NONE
4392 && dt_list
->intmod_sym_id
== sym_id
)
4395 dt_list
= dt_list
->dt_next
;
4403 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4404 with C. This is necessary for any derived type that is BIND(C) and for
4405 derived types that are parameters to functions that are BIND(C). All
4406 fields of the derived type are required to be interoperable, and are tested
4407 for such. If an error occurs, the errors are reported here, allowing for
4408 multiple errors to be handled for a single derived type. */
4411 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4413 gfc_component
*curr_comp
= NULL
;
4414 bool is_c_interop
= false;
4417 if (derived_sym
== NULL
)
4418 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4419 "unexpectedly NULL");
4421 /* If we've already looked at this derived symbol, do not look at it again
4422 so we don't repeat warnings/errors. */
4423 if (derived_sym
->ts
.is_c_interop
)
4426 /* The derived type must have the BIND attribute to be interoperable
4427 J3/04-007, Section 15.2.3. */
4428 if (derived_sym
->attr
.is_bind_c
!= 1)
4430 derived_sym
->ts
.is_c_interop
= 0;
4431 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4432 "attribute to be C interoperable", derived_sym
->name
,
4433 &(derived_sym
->declared_at
));
4437 curr_comp
= derived_sym
->components
;
4439 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4440 empty struct. Section 15.2 in Fortran 2003 states: "The following
4441 subclauses define the conditions under which a Fortran entity is
4442 interoperable. If a Fortran entity is interoperable, an equivalent
4443 entity may be defined by means of C and the Fortran entity is said
4444 to be interoperable with the C entity. There does not have to be such
4445 an interoperating C entity."
4447 if (curr_comp
== NULL
)
4449 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4450 "and may be inaccessible by the C companion processor",
4451 derived_sym
->name
, &(derived_sym
->declared_at
));
4452 derived_sym
->ts
.is_c_interop
= 1;
4453 derived_sym
->attr
.is_bind_c
= 1;
4458 /* Initialize the derived type as being C interoperable.
4459 If we find an error in the components, this will be set false. */
4460 derived_sym
->ts
.is_c_interop
= 1;
4462 /* Loop through the list of components to verify that the kind of
4463 each is a C interoperable type. */
4466 /* The components cannot be pointers (fortran sense).
4467 J3/04-007, Section 15.2.3, C1505. */
4468 if (curr_comp
->attr
.pointer
!= 0)
4470 gfc_error ("Component %qs at %L cannot have the "
4471 "POINTER attribute because it is a member "
4472 "of the BIND(C) derived type %qs at %L",
4473 curr_comp
->name
, &(curr_comp
->loc
),
4474 derived_sym
->name
, &(derived_sym
->declared_at
));
4478 if (curr_comp
->attr
.proc_pointer
!= 0)
4480 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4481 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4482 &curr_comp
->loc
, derived_sym
->name
,
4483 &derived_sym
->declared_at
);
4487 /* The components cannot be allocatable.
4488 J3/04-007, Section 15.2.3, C1505. */
4489 if (curr_comp
->attr
.allocatable
!= 0)
4491 gfc_error ("Component %qs at %L cannot have the "
4492 "ALLOCATABLE attribute because it is a member "
4493 "of the BIND(C) derived type %qs at %L",
4494 curr_comp
->name
, &(curr_comp
->loc
),
4495 derived_sym
->name
, &(derived_sym
->declared_at
));
4499 /* BIND(C) derived types must have interoperable components. */
4500 if (curr_comp
->ts
.type
== BT_DERIVED
4501 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4502 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4504 /* This should be allowed; the draft says a derived-type cannot
4505 have type parameters if it is has the BIND attribute. Type
4506 parameters seem to be for making parameterized derived types.
4507 There's no need to verify the type if it is c_ptr/c_funptr. */
4508 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4512 /* Grab the typespec for the given component and test the kind. */
4513 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4517 /* Report warning and continue since not fatal. The
4518 draft does specify a constraint that requires all fields
4519 to interoperate, but if the user says real(4), etc., it
4520 may interoperate with *something* in C, but the compiler
4521 most likely won't know exactly what. Further, it may not
4522 interoperate with the same data type(s) in C if the user
4523 recompiles with different flags (e.g., -m32 and -m64 on
4524 x86_64 and using integer(4) to claim interop with a
4526 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4527 /* If the derived type is bind(c), all fields must be
4529 gfc_warning (OPT_Wc_binding_type
,
4530 "Component %qs in derived type %qs at %L "
4531 "may not be C interoperable, even though "
4532 "derived type %qs is BIND(C)",
4533 curr_comp
->name
, derived_sym
->name
,
4534 &(curr_comp
->loc
), derived_sym
->name
);
4535 else if (warn_c_binding_type
)
4536 /* If derived type is param to bind(c) routine, or to one
4537 of the iso_c_binding procs, it must be interoperable, so
4538 all fields must interop too. */
4539 gfc_warning (OPT_Wc_binding_type
,
4540 "Component %qs in derived type %qs at %L "
4541 "may not be C interoperable",
4542 curr_comp
->name
, derived_sym
->name
,
4547 curr_comp
= curr_comp
->next
;
4548 } while (curr_comp
!= NULL
);
4550 if (derived_sym
->attr
.sequence
!= 0)
4552 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4553 "attribute because it is BIND(C)", derived_sym
->name
,
4554 &(derived_sym
->declared_at
));
4558 /* Mark the derived type as not being C interoperable if we found an
4559 error. If there were only warnings, proceed with the assumption
4560 it's interoperable. */
4562 derived_sym
->ts
.is_c_interop
= 0;
4568 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4571 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4575 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4576 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4578 tmp_sym
->attr
.is_c_interop
= 1;
4579 tmp_sym
->attr
.is_bind_c
= 1;
4580 tmp_sym
->ts
.is_c_interop
= 1;
4581 tmp_sym
->ts
.is_iso_c
= 1;
4582 tmp_sym
->ts
.type
= BT_DERIVED
;
4583 tmp_sym
->ts
.f90_type
= BT_VOID
;
4584 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4585 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4587 /* Set the c_address field of c_null_ptr and c_null_funptr to
4588 the value of NULL. */
4589 tmp_sym
->value
= gfc_get_expr ();
4590 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4591 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4592 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4593 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4594 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4595 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4596 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4597 c
->expr
->ts
.is_iso_c
= 1;
4603 /* Add a formal argument, gfc_formal_arglist, to the
4604 end of the given list of arguments. Set the reference to the
4605 provided symbol, param_sym, in the argument. */
4608 add_formal_arg (gfc_formal_arglist
**head
,
4609 gfc_formal_arglist
**tail
,
4610 gfc_formal_arglist
*formal_arg
,
4611 gfc_symbol
*param_sym
)
4613 /* Put in list, either as first arg or at the tail (curr arg). */
4615 *head
= *tail
= formal_arg
;
4618 (*tail
)->next
= formal_arg
;
4619 (*tail
) = formal_arg
;
4622 (*tail
)->sym
= param_sym
;
4623 (*tail
)->next
= NULL
;
4629 /* Add a procedure interface to the given symbol (i.e., store a
4630 reference to the list of formal arguments). */
4633 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4636 sym
->formal
= formal
;
4637 sym
->attr
.if_source
= source
;
4641 /* Copy the formal args from an existing symbol, src, into a new
4642 symbol, dest. New formal args are created, and the description of
4643 each arg is set according to the existing ones. This function is
4644 used when creating procedure declaration variables from a procedure
4645 declaration statement (see match_proc_decl()) to create the formal
4646 args based on the args of a given named interface.
4648 When an actual argument list is provided, skip the absent arguments.
4649 To be used together with gfc_se->ignore_optional. */
4652 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4653 gfc_actual_arglist
*actual
)
4655 gfc_formal_arglist
*head
= NULL
;
4656 gfc_formal_arglist
*tail
= NULL
;
4657 gfc_formal_arglist
*formal_arg
= NULL
;
4658 gfc_intrinsic_arg
*curr_arg
= NULL
;
4659 gfc_formal_arglist
*formal_prev
= NULL
;
4660 gfc_actual_arglist
*act_arg
= actual
;
4661 /* Save current namespace so we can change it for formal args. */
4662 gfc_namespace
*parent_ns
= gfc_current_ns
;
4664 /* Create a new namespace, which will be the formal ns (namespace
4665 of the formal args). */
4666 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4667 gfc_current_ns
->proc_name
= dest
;
4669 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4671 /* Skip absent arguments. */
4674 gcc_assert (act_arg
!= NULL
);
4675 if (act_arg
->expr
== NULL
)
4677 act_arg
= act_arg
->next
;
4680 act_arg
= act_arg
->next
;
4682 formal_arg
= gfc_get_formal_arglist ();
4683 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4685 /* May need to copy more info for the symbol. */
4686 formal_arg
->sym
->ts
= curr_arg
->ts
;
4687 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4688 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4689 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4690 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4691 formal_arg
->sym
->attr
.dummy
= 1;
4693 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4694 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4696 /* If this isn't the first arg, set up the next ptr. For the
4697 last arg built, the formal_arg->next will never get set to
4698 anything other than NULL. */
4699 if (formal_prev
!= NULL
)
4700 formal_prev
->next
= formal_arg
;
4702 formal_arg
->next
= NULL
;
4704 formal_prev
= formal_arg
;
4706 /* Add arg to list of formal args. */
4707 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4709 /* Validate changes. */
4710 gfc_commit_symbol (formal_arg
->sym
);
4713 /* Add the interface to the symbol. */
4714 add_proc_interface (dest
, IFSRC_DECL
, head
);
4716 /* Store the formal namespace information. */
4717 if (dest
->formal
!= NULL
)
4718 /* The current ns should be that for the dest proc. */
4719 dest
->formal_ns
= gfc_current_ns
;
4720 /* Restore the current namespace to what it was on entry. */
4721 gfc_current_ns
= parent_ns
;
4726 std_for_isocbinding_symbol (int id
)
4730 #define NAMED_INTCST(a,b,c,d) \
4733 #include "iso-c-binding.def"
4736 #define NAMED_FUNCTION(a,b,c,d) \
4739 #define NAMED_SUBROUTINE(a,b,c,d) \
4742 #include "iso-c-binding.def"
4743 #undef NAMED_FUNCTION
4744 #undef NAMED_SUBROUTINE
4747 return GFC_STD_F2003
;
4751 /* Generate the given set of C interoperable kind objects, or all
4752 interoperable kinds. This function will only be given kind objects
4753 for valid iso_c_binding defined types because this is verified when
4754 the 'use' statement is parsed. If the user gives an 'only' clause,
4755 the specific kinds are looked up; if they don't exist, an error is
4756 reported. If the user does not give an 'only' clause, all
4757 iso_c_binding symbols are generated. If a list of specific kinds
4758 is given, it must have a NULL in the first empty spot to mark the
4759 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4760 point to the symtree for c_(fun)ptr. */
4763 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4764 const char *local_name
, gfc_symtree
*dt_symtree
,
4767 const char *const name
= (local_name
&& local_name
[0])
4768 ? local_name
: c_interop_kinds_table
[s
].name
;
4769 gfc_symtree
*tmp_symtree
;
4770 gfc_symbol
*tmp_sym
= NULL
;
4773 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4776 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4778 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4779 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4780 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4783 /* Already exists in this scope so don't re-add it. */
4784 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4785 && (!tmp_sym
->attr
.generic
4786 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4787 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4789 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4790 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4792 if (gfc_derived_types
)
4794 tmp_sym
->dt_next
= gfc_derived_types
->dt_next
;
4795 gfc_derived_types
->dt_next
= tmp_sym
;
4799 tmp_sym
->dt_next
= tmp_sym
;
4801 gfc_derived_types
= tmp_sym
;
4807 /* Create the sym tree in the current ns. */
4810 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4811 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4813 /* Add to the list of tentative symbols. */
4814 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4815 tmp_sym
->old_symbol
= NULL
;
4817 tmp_sym
->gfc_new
= 1;
4819 tmp_symtree
->n
.sym
= tmp_sym
;
4824 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4825 gcc_assert (tmp_symtree
);
4826 tmp_sym
= tmp_symtree
->n
.sym
;
4829 /* Say what module this symbol belongs to. */
4830 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4831 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4832 tmp_sym
->intmod_sym_id
= s
;
4833 tmp_sym
->attr
.is_iso_c
= 1;
4834 tmp_sym
->attr
.use_assoc
= 1;
4836 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4837 || s
== ISOCBINDING_NULL_PTR
);
4842 #define NAMED_INTCST(a,b,c,d) case a :
4843 #define NAMED_REALCST(a,b,c,d) case a :
4844 #define NAMED_CMPXCST(a,b,c,d) case a :
4845 #define NAMED_LOGCST(a,b,c) case a :
4846 #define NAMED_CHARKNDCST(a,b,c) case a :
4847 #include "iso-c-binding.def"
4849 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4850 c_interop_kinds_table
[s
].value
);
4852 /* Initialize an integer constant expression node. */
4853 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4854 tmp_sym
->ts
.type
= BT_INTEGER
;
4855 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4857 /* Mark this type as a C interoperable one. */
4858 tmp_sym
->ts
.is_c_interop
= 1;
4859 tmp_sym
->ts
.is_iso_c
= 1;
4860 tmp_sym
->value
->ts
.is_c_interop
= 1;
4861 tmp_sym
->value
->ts
.is_iso_c
= 1;
4862 tmp_sym
->attr
.is_c_interop
= 1;
4864 /* Tell what f90 type this c interop kind is valid. */
4865 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4870 #define NAMED_CHARCST(a,b,c) case a :
4871 #include "iso-c-binding.def"
4873 /* Initialize an integer constant expression node for the
4874 length of the character. */
4875 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4876 &gfc_current_locus
, NULL
, 1);
4877 tmp_sym
->value
->ts
.is_c_interop
= 1;
4878 tmp_sym
->value
->ts
.is_iso_c
= 1;
4879 tmp_sym
->value
->value
.character
.length
= 1;
4880 tmp_sym
->value
->value
.character
.string
[0]
4881 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4882 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4883 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4886 /* May not need this in both attr and ts, but do need in
4887 attr for writing module file. */
4888 tmp_sym
->attr
.is_c_interop
= 1;
4890 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4891 tmp_sym
->ts
.type
= BT_CHARACTER
;
4893 /* Need to set it to the C_CHAR kind. */
4894 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4896 /* Mark this type as a C interoperable one. */
4897 tmp_sym
->ts
.is_c_interop
= 1;
4898 tmp_sym
->ts
.is_iso_c
= 1;
4900 /* Tell what f90 type this c interop kind is valid. */
4901 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4905 case ISOCBINDING_PTR
:
4906 case ISOCBINDING_FUNPTR
:
4909 gfc_component
*tmp_comp
= NULL
;
4911 /* Generate real derived type. */
4916 const char *hidden_name
;
4917 gfc_interface
*intr
, *head
;
4919 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4920 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4922 gcc_assert (tmp_symtree
== NULL
);
4923 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4924 dt_sym
= tmp_symtree
->n
.sym
;
4925 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4926 ? "c_ptr" : "c_funptr");
4928 /* Generate an artificial generic function. */
4929 head
= tmp_sym
->generic
;
4930 intr
= gfc_get_interface ();
4932 intr
->where
= gfc_current_locus
;
4934 tmp_sym
->generic
= intr
;
4936 if (!tmp_sym
->attr
.generic
4937 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4940 if (!tmp_sym
->attr
.function
4941 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4945 /* Say what module this symbol belongs to. */
4946 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4947 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4948 dt_sym
->intmod_sym_id
= s
;
4949 dt_sym
->attr
.use_assoc
= 1;
4951 /* Initialize an integer constant expression node. */
4952 dt_sym
->attr
.flavor
= FL_DERIVED
;
4953 dt_sym
->ts
.is_c_interop
= 1;
4954 dt_sym
->attr
.is_c_interop
= 1;
4955 dt_sym
->attr
.private_comp
= 1;
4956 dt_sym
->component_access
= ACCESS_PRIVATE
;
4957 dt_sym
->ts
.is_iso_c
= 1;
4958 dt_sym
->ts
.type
= BT_DERIVED
;
4959 dt_sym
->ts
.f90_type
= BT_VOID
;
4961 /* A derived type must have the bind attribute to be
4962 interoperable (J3/04-007, Section 15.2.3), even though
4963 the binding label is not used. */
4964 dt_sym
->attr
.is_bind_c
= 1;
4966 dt_sym
->attr
.referenced
= 1;
4967 dt_sym
->ts
.u
.derived
= dt_sym
;
4969 /* Add the symbol created for the derived type to the current ns. */
4970 if (gfc_derived_types
)
4972 dt_sym
->dt_next
= gfc_derived_types
->dt_next
;
4973 gfc_derived_types
->dt_next
= dt_sym
;
4977 dt_sym
->dt_next
= dt_sym
;
4979 gfc_derived_types
= dt_sym
;
4981 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4982 if (tmp_comp
== NULL
)
4985 tmp_comp
->ts
.type
= BT_INTEGER
;
4987 /* Set this because the module will need to read/write this field. */
4988 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4990 /* The kinds for c_ptr and c_funptr are the same. */
4991 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4992 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4993 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4995 /* Mark the component as C interoperable. */
4996 tmp_comp
->ts
.is_c_interop
= 1;
5001 case ISOCBINDING_NULL_PTR
:
5002 case ISOCBINDING_NULL_FUNPTR
:
5003 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
5009 gfc_commit_symbol (tmp_sym
);
5014 /* Check that a symbol is already typed. If strict is not set, an untyped
5015 symbol is acceptable for non-standard-conforming mode. */
5018 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5019 bool strict
, locus where
)
5023 if (gfc_matching_prefix
)
5026 /* Check for the type and try to give it an implicit one. */
5027 if (sym
->ts
.type
== BT_UNKNOWN
5028 && !gfc_set_default_type (sym
, 0, ns
))
5032 gfc_error ("Symbol %qs is used before it is typed at %L",
5037 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5038 " it is typed at %L", sym
->name
, &where
))
5042 /* Everything is ok. */
5047 /* Construct a typebound-procedure structure. Those are stored in a tentative
5048 list and marked `error' until symbols are committed. */
5051 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5053 gfc_typebound_proc
*result
;
5055 result
= XCNEW (gfc_typebound_proc
);
5060 latest_undo_chgset
->tbps
.safe_push (result
);
5066 /* Get the super-type of a given derived type. */
5069 gfc_get_derived_super_type (gfc_symbol
* derived
)
5071 gcc_assert (derived
);
5073 if (derived
->attr
.generic
)
5074 derived
= gfc_find_dt_in_generic (derived
);
5076 if (!derived
->attr
.extension
)
5079 gcc_assert (derived
->components
);
5080 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5081 gcc_assert (derived
->components
->ts
.u
.derived
);
5083 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5084 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5086 return derived
->components
->ts
.u
.derived
;
5090 /* Get the ultimate super-type of a given derived type. */
5093 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
5095 if (!derived
->attr
.extension
)
5098 derived
= gfc_get_derived_super_type (derived
);
5100 if (derived
->attr
.extension
)
5101 return gfc_get_ultimate_derived_super_type (derived
);
5107 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5110 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5112 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5113 t2
= gfc_get_derived_super_type (t2
);
5114 return gfc_compare_derived_types (t1
, t2
);
5118 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5119 If ts1 is nonpolymorphic, ts2 must be the same type.
5120 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5123 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5125 bool is_class1
= (ts1
->type
== BT_CLASS
);
5126 bool is_class2
= (ts2
->type
== BT_CLASS
);
5127 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5128 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5129 bool is_union1
= (ts1
->type
== BT_UNION
);
5130 bool is_union2
= (ts2
->type
== BT_UNION
);
5133 && ts1
->u
.derived
->components
5134 && ((ts1
->u
.derived
->attr
.is_class
5135 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5136 .unlimited_polymorphic
)
5137 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5140 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5141 && !is_union1
&& !is_union2
)
5142 return (ts1
->type
== ts2
->type
);
5144 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5145 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5147 if (is_derived1
&& is_class2
)
5148 return gfc_compare_derived_types (ts1
->u
.derived
,
5149 ts2
->u
.derived
->attr
.is_class
?
5150 ts2
->u
.derived
->components
->ts
.u
.derived
5152 if (is_class1
&& is_derived2
)
5153 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5154 ts1
->u
.derived
->components
->ts
.u
.derived
5157 else if (is_class1
&& is_class2
)
5158 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5159 ts1
->u
.derived
->components
->ts
.u
.derived
5161 ts2
->u
.derived
->attr
.is_class
?
5162 ts2
->u
.derived
->components
->ts
.u
.derived
5169 /* Find the parent-namespace of the current function. If we're inside
5170 BLOCK constructs, it may not be the current one. */
5173 gfc_find_proc_namespace (gfc_namespace
* ns
)
5175 while (ns
->construct_entities
)
5185 /* Check if an associate-variable should be translated as an `implicit' pointer
5186 internally (if it is associated to a variable and not an array with
5190 gfc_is_associate_pointer (gfc_symbol
* sym
)
5195 if (sym
->ts
.type
== BT_CLASS
)
5198 if (sym
->ts
.type
== BT_CHARACTER
5200 && sym
->assoc
->target
5201 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5204 if (!sym
->assoc
->variable
)
5207 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5215 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5217 gfc_interface
*intr
= NULL
;
5219 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5222 if (sym
->attr
.generic
)
5223 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5224 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5226 return intr
? intr
->sym
: NULL
;
5230 /* Get the dummy arguments from a procedure symbol. If it has been declared
5231 via a PROCEDURE statement with a named interface, ts.interface will be set
5232 and the arguments need to be taken from there. */
5234 gfc_formal_arglist
*
5235 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5237 gfc_formal_arglist
*dummies
;
5239 dummies
= sym
->formal
;
5240 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5241 dummies
= sym
->ts
.interface
->formal
;