1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2019 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
)
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
)
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
)))
1213 duplicate_attr ("POINTER", where
);
1217 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1218 || (attr
->if_source
== IFSRC_IFBODY
1219 && !gfc_find_state (COMP_INTERFACE
)))
1220 attr
->proc_pointer
= 1;
1224 return gfc_check_conflict (attr
, NULL
, where
);
1229 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1232 if (check_used (attr
, NULL
, where
))
1235 attr
->cray_pointer
= 1;
1236 return gfc_check_conflict (attr
, NULL
, where
);
1241 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1244 if (check_used (attr
, NULL
, where
))
1247 if (attr
->cray_pointee
)
1249 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1250 " statements", where
);
1254 attr
->cray_pointee
= 1;
1255 return gfc_check_conflict (attr
, NULL
, where
);
1260 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1262 if (check_used (attr
, name
, where
))
1265 if (attr
->is_protected
)
1267 if (!gfc_notify_std (GFC_STD_LEGACY
,
1268 "Duplicate PROTECTED attribute specified at %L",
1273 attr
->is_protected
= 1;
1274 return gfc_check_conflict (attr
, name
, where
);
1279 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1282 if (check_used (attr
, name
, where
))
1286 return gfc_check_conflict (attr
, name
, where
);
1291 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1295 if (check_used (attr
, name
, where
))
1298 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1301 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1306 if (s
== SAVE_EXPLICIT
)
1307 gfc_unset_implicit_pure (NULL
);
1309 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
1310 && (flag_automatic
|| pedantic
))
1312 if (!gfc_notify_std (GFC_STD_LEGACY
,
1313 "Duplicate SAVE attribute specified at %L",
1319 return gfc_check_conflict (attr
, name
, where
);
1324 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1327 if (check_used (attr
, name
, where
))
1332 if (!gfc_notify_std (GFC_STD_LEGACY
,
1333 "Duplicate VALUE attribute specified at %L",
1339 return gfc_check_conflict (attr
, name
, where
);
1344 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1346 /* No check_used needed as 11.2.1 of the F2003 standard allows
1347 that the local identifier made accessible by a use statement can be
1348 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1350 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1351 if (!gfc_notify_std (GFC_STD_LEGACY
,
1352 "Duplicate VOLATILE attribute specified at %L",
1356 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1357 shall not appear in a pure subprogram.
1359 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1360 construct within a pure subprogram, shall not have the SAVE or
1361 VOLATILE attribute. */
1362 if (gfc_pure (NULL
))
1364 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1365 "PURE procedure", where
);
1370 attr
->volatile_
= 1;
1371 attr
->volatile_ns
= gfc_current_ns
;
1372 return gfc_check_conflict (attr
, name
, where
);
1377 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1379 /* No check_used needed as 11.2.1 of the F2003 standard allows
1380 that the local identifier made accessible by a use statement can be
1381 given a ASYNCHRONOUS attribute. */
1383 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1384 if (!gfc_notify_std (GFC_STD_LEGACY
,
1385 "Duplicate ASYNCHRONOUS attribute specified at %L",
1389 attr
->asynchronous
= 1;
1390 attr
->asynchronous_ns
= gfc_current_ns
;
1391 return gfc_check_conflict (attr
, name
, where
);
1396 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1399 if (check_used (attr
, name
, where
))
1402 if (attr
->threadprivate
)
1404 duplicate_attr ("THREADPRIVATE", where
);
1408 attr
->threadprivate
= 1;
1409 return gfc_check_conflict (attr
, name
, where
);
1414 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1418 if (check_used (attr
, name
, where
))
1421 if (attr
->omp_declare_target
)
1424 attr
->omp_declare_target
= 1;
1425 return gfc_check_conflict (attr
, name
, where
);
1430 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1434 if (check_used (attr
, name
, where
))
1437 if (attr
->omp_declare_target_link
)
1440 attr
->omp_declare_target_link
= 1;
1441 return gfc_check_conflict (attr
, name
, where
);
1446 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1449 if (check_used (attr
, name
, where
))
1452 if (attr
->oacc_declare_create
)
1455 attr
->oacc_declare_create
= 1;
1456 return gfc_check_conflict (attr
, name
, where
);
1461 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1464 if (check_used (attr
, name
, where
))
1467 if (attr
->oacc_declare_copyin
)
1470 attr
->oacc_declare_copyin
= 1;
1471 return gfc_check_conflict (attr
, name
, where
);
1476 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1479 if (check_used (attr
, name
, where
))
1482 if (attr
->oacc_declare_deviceptr
)
1485 attr
->oacc_declare_deviceptr
= 1;
1486 return gfc_check_conflict (attr
, name
, where
);
1491 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1494 if (check_used (attr
, name
, where
))
1497 if (attr
->oacc_declare_device_resident
)
1500 attr
->oacc_declare_device_resident
= 1;
1501 return gfc_check_conflict (attr
, name
, where
);
1506 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1509 if (check_used (attr
, NULL
, where
))
1514 duplicate_attr ("TARGET", where
);
1519 return gfc_check_conflict (attr
, NULL
, where
);
1524 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1527 if (check_used (attr
, name
, where
))
1530 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1532 return gfc_check_conflict (attr
, name
, where
);
1537 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1540 if (check_used (attr
, name
, where
))
1543 /* Duplicate attribute already checked for. */
1544 attr
->in_common
= 1;
1545 return gfc_check_conflict (attr
, name
, where
);
1550 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1553 /* Duplicate attribute already checked for. */
1554 attr
->in_equivalence
= 1;
1555 if (!gfc_check_conflict (attr
, name
, where
))
1558 if (attr
->flavor
== FL_VARIABLE
)
1561 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1566 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1569 if (check_used (attr
, name
, where
))
1573 return gfc_check_conflict (attr
, name
, where
);
1578 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1581 attr
->in_namelist
= 1;
1582 return gfc_check_conflict (attr
, name
, where
);
1587 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1590 if (check_used (attr
, name
, where
))
1594 return gfc_check_conflict (attr
, name
, where
);
1599 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1602 if (check_used (attr
, NULL
, where
))
1605 if (attr
->elemental
)
1607 duplicate_attr ("ELEMENTAL", where
);
1611 attr
->elemental
= 1;
1612 return gfc_check_conflict (attr
, NULL
, where
);
1617 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1620 if (check_used (attr
, NULL
, where
))
1625 duplicate_attr ("PURE", where
);
1630 return gfc_check_conflict (attr
, NULL
, where
);
1635 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1638 if (check_used (attr
, NULL
, where
))
1641 if (attr
->recursive
)
1643 duplicate_attr ("RECURSIVE", where
);
1647 attr
->recursive
= 1;
1648 return gfc_check_conflict (attr
, NULL
, where
);
1653 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1656 if (check_used (attr
, name
, where
))
1661 duplicate_attr ("ENTRY", where
);
1666 return gfc_check_conflict (attr
, name
, where
);
1671 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1674 if (attr
->flavor
!= FL_PROCEDURE
1675 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1679 return gfc_check_conflict (attr
, name
, where
);
1684 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1687 if (attr
->flavor
!= FL_PROCEDURE
1688 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1691 attr
->subroutine
= 1;
1693 /* If we are looking at a BLOCK DATA statement and we encounter a
1694 name with a leading underscore (which must be
1695 compiler-generated), do not check. See PR 84394. */
1697 if (name
&& *name
!= '_' && gfc_current_state () != COMP_BLOCK_DATA
)
1698 return gfc_check_conflict (attr
, name
, where
);
1705 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1708 if (attr
->flavor
!= FL_PROCEDURE
1709 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1713 return gfc_check_conflict (attr
, name
, where
);
1718 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1721 if (check_used (attr
, NULL
, where
))
1724 if (attr
->flavor
!= FL_PROCEDURE
1725 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1728 if (attr
->procedure
)
1730 duplicate_attr ("PROCEDURE", where
);
1734 attr
->procedure
= 1;
1736 return gfc_check_conflict (attr
, NULL
, where
);
1741 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1745 duplicate_attr ("ABSTRACT", where
);
1751 return gfc_check_conflict (attr
, NULL
, where
);
1755 /* Flavors are special because some flavors are not what Fortran
1756 considers attributes and can be reaffirmed multiple times. */
1759 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1763 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1764 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1765 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1768 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1771 /* Copying a procedure dummy argument for a module procedure in a
1772 submodule results in the flavor being copied and would result in
1773 an error without this. */
1774 if (gfc_new_block
&& gfc_new_block
->abr_modproc_decl
1775 && attr
->flavor
== f
&& f
== FL_PROCEDURE
)
1778 if (attr
->flavor
!= FL_UNKNOWN
)
1781 where
= &gfc_current_locus
;
1784 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1785 gfc_code2string (flavors
, attr
->flavor
), name
,
1786 gfc_code2string (flavors
, f
), where
);
1788 gfc_error ("%s attribute conflicts with %s attribute at %L",
1789 gfc_code2string (flavors
, attr
->flavor
),
1790 gfc_code2string (flavors
, f
), where
);
1797 return gfc_check_conflict (attr
, name
, where
);
1802 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1803 const char *name
, locus
*where
)
1806 if (check_used (attr
, name
, where
))
1809 if (attr
->flavor
!= FL_PROCEDURE
1810 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1814 where
= &gfc_current_locus
;
1816 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
1817 && attr
->access
== ACCESS_UNKNOWN
)
1819 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1820 && !gfc_notification_std (GFC_STD_F2008
))
1821 gfc_error ("%s procedure at %L is already declared as %s "
1822 "procedure. \nF2008: A pointer function assignment "
1823 "is ambiguous if it is the first executable statement "
1824 "after the specification block. Please add any other "
1825 "kind of executable statement before it. FIXME",
1826 gfc_code2string (procedures
, t
), where
,
1827 gfc_code2string (procedures
, attr
->proc
));
1829 gfc_error ("%s procedure at %L is already declared as %s "
1830 "procedure", gfc_code2string (procedures
, t
), where
,
1831 gfc_code2string (procedures
, attr
->proc
));
1838 /* Statement functions are always scalar and functions. */
1839 if (t
== PROC_ST_FUNCTION
1840 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1841 || attr
->dimension
))
1844 return gfc_check_conflict (attr
, name
, where
);
1849 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1852 if (check_used (attr
, NULL
, where
))
1855 if (attr
->intent
== INTENT_UNKNOWN
)
1857 attr
->intent
= intent
;
1858 return gfc_check_conflict (attr
, NULL
, where
);
1862 where
= &gfc_current_locus
;
1864 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1865 gfc_intent_string (attr
->intent
),
1866 gfc_intent_string (intent
), where
);
1872 /* No checks for use-association in public and private statements. */
1875 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1876 const char *name
, locus
*where
)
1879 if (attr
->access
== ACCESS_UNKNOWN
1880 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1882 attr
->access
= access
;
1883 return gfc_check_conflict (attr
, name
, where
);
1887 where
= &gfc_current_locus
;
1888 gfc_error ("ACCESS specification at %L was already specified", where
);
1894 /* Set the is_bind_c field for the given symbol_attribute. */
1897 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1898 int is_proc_lang_bind_spec
)
1901 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1902 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1903 "variables or common blocks", where
);
1904 else if (attr
->is_bind_c
)
1905 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1907 attr
->is_bind_c
= 1;
1910 where
= &gfc_current_locus
;
1912 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1915 return gfc_check_conflict (attr
, name
, where
);
1919 /* Set the extension field for the given symbol_attribute. */
1922 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1925 where
= &gfc_current_locus
;
1927 if (attr
->extension
)
1928 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1930 attr
->extension
= 1;
1932 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1940 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1941 gfc_formal_arglist
* formal
, locus
*where
)
1943 if (check_used (&sym
->attr
, sym
->name
, where
))
1946 /* Skip the following checks in the case of a module_procedures in a
1947 submodule since they will manifestly fail. */
1948 if (sym
->attr
.module_procedure
== 1
1949 && source
== IFSRC_DECL
)
1953 where
= &gfc_current_locus
;
1955 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1956 && sym
->attr
.if_source
!= IFSRC_DECL
)
1958 gfc_error ("Symbol %qs at %L already has an explicit interface",
1963 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1965 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1966 "body", sym
->name
, where
);
1971 sym
->formal
= formal
;
1972 sym
->attr
.if_source
= source
;
1978 /* Add a type to a symbol. */
1981 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1987 where
= &gfc_current_locus
;
1990 type
= sym
->result
->ts
.type
;
1992 type
= sym
->ts
.type
;
1994 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1995 type
= sym
->ns
->proc_name
->ts
.type
;
1997 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1998 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1999 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
2000 && !sym
->attr
.module_procedure
)
2002 if (sym
->attr
.use_assoc
)
2003 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2004 "use-associated at %L", sym
->name
, where
, sym
->module
,
2007 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
2008 where
, gfc_basic_typename (type
));
2012 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
2014 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2015 sym
->name
, where
, gfc_basic_typename (ts
->type
));
2019 flavor
= sym
->attr
.flavor
;
2021 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
2022 || flavor
== FL_LABEL
2023 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
2024 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
2026 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
2035 /* Clears all attributes. */
2038 gfc_clear_attr (symbol_attribute
*attr
)
2040 memset (attr
, 0, sizeof (symbol_attribute
));
2044 /* Check for missing attributes in the new symbol. Currently does
2045 nothing, but it's not clear that it is unnecessary yet. */
2048 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2049 locus
*where ATTRIBUTE_UNUSED
)
2056 /* Copy an attribute to a symbol attribute, bit by bit. Some
2057 attributes have a lot of side-effects but cannot be present given
2058 where we are called from, so we ignore some bits. */
2061 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2063 int is_proc_lang_bind_spec
;
2065 /* In line with the other attributes, we only add bits but do not remove
2066 them; cf. also PR 41034. */
2067 dest
->ext_attr
|= src
->ext_attr
;
2069 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2072 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2074 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2076 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2078 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2080 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2082 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2084 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2086 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2088 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2090 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2092 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2094 if (src
->threadprivate
2095 && !gfc_add_threadprivate (dest
, NULL
, where
))
2097 if (src
->omp_declare_target
2098 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2100 if (src
->omp_declare_target_link
2101 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2103 if (src
->oacc_declare_create
2104 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2106 if (src
->oacc_declare_copyin
2107 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2109 if (src
->oacc_declare_deviceptr
2110 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2112 if (src
->oacc_declare_device_resident
2113 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2115 if (src
->target
&& !gfc_add_target (dest
, where
))
2117 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2119 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2124 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2127 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2130 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2132 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2134 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2137 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2139 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2141 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2143 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2146 if (src
->flavor
!= FL_UNKNOWN
2147 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2150 if (src
->intent
!= INTENT_UNKNOWN
2151 && !gfc_add_intent (dest
, src
->intent
, where
))
2154 if (src
->access
!= ACCESS_UNKNOWN
2155 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2158 if (!gfc_missing_attr (dest
, where
))
2161 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2163 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2166 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2168 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2171 if (src
->is_c_interop
)
2172 dest
->is_c_interop
= 1;
2176 if (src
->external
&& !gfc_add_external (dest
, where
))
2178 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2180 if (src
->proc_pointer
)
2181 dest
->proc_pointer
= 1;
2190 /* A function to generate a dummy argument symbol using that from the
2191 interface declaration. Can be used for the result symbol as well if
2195 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2199 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2203 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2206 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2207 &gfc_current_locus
))
2210 if ((*dsym
)->attr
.dimension
)
2211 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2213 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2215 if ((*dsym
) != NULL
&& !result
2216 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2217 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2219 else if ((*dsym
) != NULL
&& result
2220 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2221 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2228 /************** Component name management ************/
2230 /* Component names of a derived type form their own little namespaces
2231 that are separate from all other spaces. The space is composed of
2232 a singly linked list of gfc_component structures whose head is
2233 located in the parent symbol. */
2236 /* Add a component name to a symbol. The call fails if the name is
2237 already present. On success, the component pointer is modified to
2238 point to the additional component structure. */
2241 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2242 gfc_component
**component
)
2244 gfc_component
*p
, *tail
;
2246 /* Check for existing components with the same name, but not for union
2247 components or containers. Unions and maps are anonymous so they have
2248 unique internal names which will never conflict.
2249 Don't use gfc_find_component here because it calls gfc_use_derived,
2250 but the derived type may not be fully defined yet. */
2253 for (p
= sym
->components
; p
; p
= p
->next
)
2255 if (strcmp (p
->name
, name
) == 0)
2257 gfc_error ("Component %qs at %C already declared at %L",
2265 if (sym
->attr
.extension
2266 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2267 name
, true, true, NULL
))
2269 gfc_error ("Component %qs at %C already in the parent type "
2270 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2274 /* Allocate a new component. */
2275 p
= gfc_get_component ();
2278 sym
->components
= p
;
2282 p
->name
= gfc_get_string ("%s", name
);
2283 p
->loc
= gfc_current_locus
;
2284 p
->ts
.type
= BT_UNKNOWN
;
2291 /* Recursive function to switch derived types of all symbol in a
2295 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2303 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2304 sym
->ts
.u
.derived
= to
;
2306 switch_types (st
->left
, from
, to
);
2307 switch_types (st
->right
, from
, to
);
2311 /* This subroutine is called when a derived type is used in order to
2312 make the final determination about which version to use. The
2313 standard requires that a type be defined before it is 'used', but
2314 such types can appear in IMPLICIT statements before the actual
2315 definition. 'Using' in this context means declaring a variable to
2316 be that type or using the type constructor.
2318 If a type is used and the components haven't been defined, then we
2319 have to have a derived type in a parent unit. We find the node in
2320 the other namespace and point the symtree node in this namespace to
2321 that node. Further reference to this name point to the correct
2322 node. If we can't find the node in a parent namespace, then we have
2325 This subroutine takes a pointer to a symbol node and returns a
2326 pointer to the translated node or NULL for an error. Usually there
2327 is no translation and we return the node we were passed. */
2330 gfc_use_derived (gfc_symbol
*sym
)
2340 if (sym
->attr
.unlimited_polymorphic
)
2343 if (sym
->attr
.generic
)
2344 sym
= gfc_find_dt_in_generic (sym
);
2346 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2347 return sym
; /* Already defined. */
2349 if (sym
->ns
->parent
== NULL
)
2352 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2354 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2358 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2361 /* Get rid of symbol sym, translating all references to s. */
2362 for (i
= 0; i
< GFC_LETTERS
; i
++)
2364 t
= &sym
->ns
->default_type
[i
];
2365 if (t
->u
.derived
== sym
)
2369 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2374 /* Unlink from list of modified symbols. */
2375 gfc_commit_symbol (sym
);
2377 switch_types (sym
->ns
->sym_root
, sym
, s
);
2379 /* TODO: Also have to replace sym -> s in other lists like
2380 namelists, common lists and interface lists. */
2381 gfc_free_symbol (sym
);
2386 gfc_error ("Derived type %qs at %C is being used before it is defined",
2392 /* Find the component with the given name in the union type symbol.
2393 If ref is not NULL it will be set to the chain of components through which
2394 the component can actually be accessed. This is necessary for unions because
2395 intermediate structures may be maps, nested structures, or other unions,
2396 all of which may (or must) be 'anonymous' to user code. */
2398 static gfc_component
*
2399 find_union_component (gfc_symbol
*un
, const char *name
,
2400 bool noaccess
, gfc_ref
**ref
)
2402 gfc_component
*m
, *check
;
2403 gfc_ref
*sref
, *tmp
;
2405 for (m
= un
->components
; m
; m
= m
->next
)
2407 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2411 /* Found component somewhere in m; chain the refs together. */
2415 sref
= gfc_get_ref ();
2416 sref
->type
= REF_COMPONENT
;
2417 sref
->u
.c
.component
= m
;
2418 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2423 /* Other checks (such as access) were done in the recursive calls. */
2430 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2431 the number of total candidates in CANDIDATES_LEN. */
2434 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2436 size_t &candidates_len
)
2438 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2439 vec_push (candidates
, candidates_len
, p
->name
);
2443 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2446 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2448 char **candidates
= NULL
;
2449 size_t candidates_len
= 0;
2450 lookup_component_fuzzy_find_candidates (component
, candidates
,
2452 return gfc_closest_fuzzy_match (member
, candidates
);
2456 /* Given a derived type node and a component name, try to locate the
2457 component structure. Returns the NULL pointer if the component is
2458 not found or the components are private. If noaccess is set, no access
2459 checks are done. If silent is set, an error will not be generated if
2460 the component cannot be found or accessed.
2462 If ref is not NULL, *ref is set to represent the chain of components
2463 required to get to the ultimate component.
2465 If the component is simply a direct subcomponent, or is inherited from a
2466 parent derived type in the given derived type, this is a single ref with its
2467 component set to the returned component.
2469 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2470 when the component is found through an implicit chain of nested union and
2471 map components. Unions and maps are "anonymous" substructures in FORTRAN
2472 which cannot be explicitly referenced, but the reference chain must be
2473 considered as in C for backend translation to correctly compute layouts.
2474 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2477 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2478 bool noaccess
, bool silent
, gfc_ref
**ref
)
2480 gfc_component
*p
, *check
;
2481 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2483 if (name
== NULL
|| sym
== NULL
)
2486 if (sym
->attr
.flavor
== FL_DERIVED
)
2487 sym
= gfc_use_derived (sym
);
2489 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2494 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2495 if (sym
->attr
.flavor
== FL_UNION
)
2496 return find_union_component (sym
, name
, noaccess
, ref
);
2498 if (ref
) *ref
= NULL
;
2499 for (p
= sym
->components
; p
; p
= p
->next
)
2501 /* Nest search into union's maps. */
2502 if (p
->ts
.type
== BT_UNION
)
2504 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2510 sref
= gfc_get_ref ();
2511 sref
->type
= REF_COMPONENT
;
2512 sref
->u
.c
.component
= p
;
2513 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2520 else if (strcmp (p
->name
, name
) == 0)
2526 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2528 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2529 if (p
->attr
.access
== ACCESS_PRIVATE
||
2530 (p
->attr
.access
!= ACCESS_PUBLIC
2531 && sym
->component_access
== ACCESS_PRIVATE
2532 && !is_parent_comp
))
2535 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2542 && sym
->attr
.extension
2543 && sym
->components
->ts
.type
== BT_DERIVED
)
2545 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2546 noaccess
, silent
, ref
);
2547 /* Do not overwrite the error. */
2552 if (p
== NULL
&& !silent
)
2554 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2556 gfc_error ("%qs at %C is not a member of the %qs structure"
2557 "; did you mean %qs?",
2558 name
, sym
->name
, guessed
);
2560 gfc_error ("%qs at %C is not a member of the %qs structure",
2564 /* Component was found; build the ultimate component reference. */
2565 if (p
!= NULL
&& ref
)
2567 tmp
= gfc_get_ref ();
2568 tmp
->type
= REF_COMPONENT
;
2569 tmp
->u
.c
.component
= p
;
2571 /* Link the final component ref to the end of the chain of subrefs. */
2575 for (; sref
->next
; sref
= sref
->next
)
2587 /* Given a symbol, free all of the component structures and everything
2591 free_components (gfc_component
*p
)
2599 gfc_free_array_spec (p
->as
);
2600 gfc_free_expr (p
->initializer
);
2602 gfc_free_expr (p
->kind_expr
);
2604 gfc_free_actual_arglist (p
->param_list
);
2612 /******************** Statement label management ********************/
2614 /* Comparison function for statement labels, used for managing the
2618 compare_st_labels (void *a1
, void *b1
)
2620 int a
= ((gfc_st_label
*) a1
)->value
;
2621 int b
= ((gfc_st_label
*) b1
)->value
;
2627 /* Free a single gfc_st_label structure, making sure the tree is not
2628 messed up. This function is called only when some parse error
2632 gfc_free_st_label (gfc_st_label
*label
)
2638 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2640 if (label
->format
!= NULL
)
2641 gfc_free_expr (label
->format
);
2647 /* Free a whole tree of gfc_st_label structures. */
2650 free_st_labels (gfc_st_label
*label
)
2656 free_st_labels (label
->left
);
2657 free_st_labels (label
->right
);
2659 if (label
->format
!= NULL
)
2660 gfc_free_expr (label
->format
);
2665 /* Given a label number, search for and return a pointer to the label
2666 structure, creating it if it does not exist. */
2669 gfc_get_st_label (int labelno
)
2674 if (gfc_current_state () == COMP_DERIVED
)
2675 ns
= gfc_current_block ()->f2k_derived
;
2678 /* Find the namespace of the scoping unit:
2679 If we're in a BLOCK construct, jump to the parent namespace. */
2680 ns
= gfc_current_ns
;
2681 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2685 /* First see if the label is already in this namespace. */
2689 if (lp
->value
== labelno
)
2692 if (lp
->value
< labelno
)
2698 lp
= XCNEW (gfc_st_label
);
2700 lp
->value
= labelno
;
2701 lp
->defined
= ST_LABEL_UNKNOWN
;
2702 lp
->referenced
= ST_LABEL_UNKNOWN
;
2705 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2711 /* Called when a statement with a statement label is about to be
2712 accepted. We add the label to the list of the current namespace,
2713 making sure it hasn't been defined previously and referenced
2717 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2721 labelno
= lp
->value
;
2723 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2724 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2725 &lp
->where
, label_locus
);
2728 lp
->where
= *label_locus
;
2732 case ST_LABEL_FORMAT
:
2733 if (lp
->referenced
== ST_LABEL_TARGET
2734 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2735 gfc_error ("Label %d at %C already referenced as branch target",
2738 lp
->defined
= ST_LABEL_FORMAT
;
2742 case ST_LABEL_TARGET
:
2743 case ST_LABEL_DO_TARGET
:
2744 if (lp
->referenced
== ST_LABEL_FORMAT
)
2745 gfc_error ("Label %d at %C already referenced as a format label",
2750 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2751 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2752 "DO termination statement which is not END DO"
2753 " or CONTINUE with label %d at %C", labelno
))
2758 lp
->defined
= ST_LABEL_BAD_TARGET
;
2759 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2765 /* Reference a label. Given a label and its type, see if that
2766 reference is consistent with what is known about that label,
2767 updating the unknown state. Returns false if something goes
2771 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2773 gfc_sl_type label_type
;
2780 labelno
= lp
->value
;
2782 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2783 label_type
= lp
->defined
;
2786 label_type
= lp
->referenced
;
2787 lp
->where
= gfc_current_locus
;
2790 if (label_type
== ST_LABEL_FORMAT
2791 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2793 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2798 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2799 || label_type
== ST_LABEL_BAD_TARGET
)
2800 && type
== ST_LABEL_FORMAT
)
2802 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2807 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2808 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2809 "Shared DO termination label %d at %C", labelno
))
2812 if (type
== ST_LABEL_DO_TARGET
2813 && !gfc_notify_std (GFC_STD_F2018_OBS
, "Labeled DO statement "
2814 "at %L", &gfc_current_locus
))
2817 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2818 lp
->referenced
= type
;
2826 /************** Symbol table management subroutines ****************/
2828 /* Basic details: Fortran 95 requires a potentially unlimited number
2829 of distinct namespaces when compiling a program unit. This case
2830 occurs during a compilation of internal subprograms because all of
2831 the internal subprograms must be read before we can start
2832 generating code for the host.
2834 Given the tricky nature of the Fortran grammar, we must be able to
2835 undo changes made to a symbol table if the current interpretation
2836 of a statement is found to be incorrect. Whenever a symbol is
2837 looked up, we make a copy of it and link to it. All of these
2838 symbols are kept in a vector so that we can commit or
2839 undo the changes at a later time.
2841 A symtree may point to a symbol node outside of its namespace. In
2842 this case, that symbol has been used as a host associated variable
2843 at some previous time. */
2845 /* Allocate a new namespace structure. Copies the implicit types from
2846 PARENT if PARENT_TYPES is set. */
2849 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2856 ns
= XCNEW (gfc_namespace
);
2857 ns
->sym_root
= NULL
;
2858 ns
->uop_root
= NULL
;
2859 ns
->tb_sym_root
= NULL
;
2860 ns
->finalizers
= NULL
;
2861 ns
->default_access
= ACCESS_UNKNOWN
;
2862 ns
->parent
= parent
;
2864 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2866 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2867 ns
->tb_op
[in
] = NULL
;
2870 /* Initialize default implicit types. */
2871 for (i
= 'a'; i
<= 'z'; i
++)
2873 ns
->set_flag
[i
- 'a'] = 0;
2874 ts
= &ns
->default_type
[i
- 'a'];
2876 if (parent_types
&& ns
->parent
!= NULL
)
2878 /* Copy parent settings. */
2879 *ts
= ns
->parent
->default_type
[i
- 'a'];
2883 if (flag_implicit_none
!= 0)
2889 if ('i' <= i
&& i
<= 'n')
2891 ts
->type
= BT_INTEGER
;
2892 ts
->kind
= gfc_default_integer_kind
;
2897 ts
->kind
= gfc_default_real_kind
;
2901 if (parent_types
&& ns
->parent
!= NULL
)
2902 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2910 /* Comparison function for symtree nodes. */
2913 compare_symtree (void *_st1
, void *_st2
)
2915 gfc_symtree
*st1
, *st2
;
2917 st1
= (gfc_symtree
*) _st1
;
2918 st2
= (gfc_symtree
*) _st2
;
2920 return strcmp (st1
->name
, st2
->name
);
2924 /* Allocate a new symtree node and associate it with the new symbol. */
2927 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2931 st
= XCNEW (gfc_symtree
);
2932 st
->name
= gfc_get_string ("%s", name
);
2934 gfc_insert_bbt (root
, st
, compare_symtree
);
2939 /* Delete a symbol from the tree. Does not free the symbol itself! */
2942 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2944 gfc_symtree st
, *st0
;
2947 /* Submodules are marked as mod.submod. When freeing a submodule
2948 symbol, the symtree only has "submod", so adjust that here. */
2950 p
= strrchr(name
, '.');
2956 st0
= gfc_find_symtree (*root
, p
);
2958 st
.name
= gfc_get_string ("%s", p
);
2959 gfc_delete_bbt (root
, &st
, compare_symtree
);
2965 /* Given a root symtree node and a name, try to find the symbol within
2966 the namespace. Returns NULL if the symbol is not found. */
2969 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2975 c
= strcmp (name
, st
->name
);
2979 st
= (c
< 0) ? st
->left
: st
->right
;
2986 /* Return a symtree node with a name that is guaranteed to be unique
2987 within the namespace and corresponds to an illegal fortran name. */
2990 gfc_get_unique_symtree (gfc_namespace
*ns
)
2992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2993 static int serial
= 0;
2995 sprintf (name
, "@%d", serial
++);
2996 return gfc_new_symtree (&ns
->sym_root
, name
);
3000 /* Given a name find a user operator node, creating it if it doesn't
3001 exist. These are much simpler than symbols because they can't be
3002 ambiguous with one another. */
3005 gfc_get_uop (const char *name
)
3009 gfc_namespace
*ns
= gfc_current_ns
;
3013 st
= gfc_find_symtree (ns
->uop_root
, name
);
3017 st
= gfc_new_symtree (&ns
->uop_root
, name
);
3019 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
3020 uop
->name
= gfc_get_string ("%s", name
);
3021 uop
->access
= ACCESS_UNKNOWN
;
3028 /* Given a name find the user operator node. Returns NULL if it does
3032 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3037 ns
= gfc_current_ns
;
3039 st
= gfc_find_symtree (ns
->uop_root
, name
);
3040 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3044 /* Update a symbol's common_block field, and take care of the associated
3045 memory management. */
3048 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3050 if (sym
->common_block
== common_block
)
3053 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3055 sym
->common_block
->refs
--;
3056 if (sym
->common_block
->refs
== 0)
3057 free (sym
->common_block
);
3059 sym
->common_block
= common_block
;
3063 /* Remove a gfc_symbol structure and everything it points to. */
3066 gfc_free_symbol (gfc_symbol
*sym
)
3072 gfc_free_array_spec (sym
->as
);
3074 free_components (sym
->components
);
3076 gfc_free_expr (sym
->value
);
3078 gfc_free_namelist (sym
->namelist
);
3080 if (sym
->ns
!= sym
->formal_ns
)
3081 gfc_free_namespace (sym
->formal_ns
);
3083 if (!sym
->attr
.generic_copy
)
3084 gfc_free_interface (sym
->generic
);
3086 gfc_free_formal_arglist (sym
->formal
);
3088 gfc_free_namespace (sym
->f2k_derived
);
3090 set_symbol_common_block (sym
, NULL
);
3092 if (sym
->param_list
)
3093 gfc_free_actual_arglist (sym
->param_list
);
3099 /* Decrease the reference counter and free memory when we reach zero. */
3102 gfc_release_symbol (gfc_symbol
*sym
)
3107 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
3108 && (!sym
->attr
.entry
|| !sym
->module
))
3110 /* As formal_ns contains a reference to sym, delete formal_ns just
3111 before the deletion of sym. */
3112 gfc_namespace
*ns
= sym
->formal_ns
;
3113 sym
->formal_ns
= NULL
;
3114 gfc_free_namespace (ns
);
3121 gcc_assert (sym
->refs
== 0);
3122 gfc_free_symbol (sym
);
3126 /* Allocate and initialize a new symbol node. */
3129 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3133 p
= XCNEW (gfc_symbol
);
3135 gfc_clear_ts (&p
->ts
);
3136 gfc_clear_attr (&p
->attr
);
3139 p
->declared_at
= gfc_current_locus
;
3141 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
3142 gfc_internal_error ("new_symbol(): Symbol name too long");
3144 p
->name
= gfc_get_string ("%s", name
);
3146 /* Make sure flags for symbol being C bound are clear initially. */
3147 p
->attr
.is_bind_c
= 0;
3148 p
->attr
.is_iso_c
= 0;
3150 /* Clear the ptrs we may need. */
3151 p
->common_block
= NULL
;
3152 p
->f2k_derived
= NULL
;
3155 p
->fn_result_spec
= 0;
3161 /* Generate an error if a symbol is ambiguous. */
3164 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3167 if (st
->n
.sym
->module
)
3168 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3169 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3171 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3172 "from current program unit", name
, st
->n
.sym
->name
);
3176 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3177 selector on the stack. If yes, replace it by the corresponding temporary. */
3180 select_type_insert_tmp (gfc_symtree
**st
)
3182 gfc_select_type_stack
*stack
= select_type_stack
;
3183 for (; stack
; stack
= stack
->prev
)
3184 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3187 select_type_insert_tmp (st
);
3193 /* Look for a symtree in the current procedure -- that is, go up to
3194 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3197 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3201 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3205 if (!ns
->construct_entities
)
3214 /* Search for a symtree starting in the current namespace, resorting to
3215 any parent namespaces if requested by a nonzero parent_flag.
3216 Returns nonzero if the name is ambiguous. */
3219 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3220 gfc_symtree
**result
)
3225 ns
= gfc_current_ns
;
3229 st
= gfc_find_symtree (ns
->sym_root
, name
);
3232 select_type_insert_tmp (&st
);
3235 /* Ambiguous generic interfaces are permitted, as long
3236 as the specific interfaces are different. */
3237 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3239 ambiguous_symbol (name
, st
);
3249 /* Don't escape an interface block. */
3250 if (ns
&& !ns
->has_import_set
3251 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3258 if (gfc_current_state() == COMP_DERIVED
3259 && gfc_current_block ()->attr
.pdt_template
)
3261 gfc_symbol
*der
= gfc_current_block ();
3262 for (; der
; der
= gfc_get_derived_super_type (der
))
3264 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3266 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3281 /* Same, but returns the symbol instead. */
3284 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3285 gfc_symbol
**result
)
3290 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3295 *result
= st
->n
.sym
;
3301 /* Tells whether there is only one set of changes in the stack. */
3304 single_undo_checkpoint_p (void)
3306 if (latest_undo_chgset
== &default_undo_chgset_var
)
3308 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3313 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3318 /* Save symbol with the information necessary to back it out. */
3321 gfc_save_symbol_data (gfc_symbol
*sym
)
3326 if (!single_undo_checkpoint_p ())
3328 /* If there is more than one change set, look for the symbol in the
3329 current one. If it is found there, we can reuse it. */
3330 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3333 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3337 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3340 s
= XCNEW (gfc_symbol
);
3342 sym
->old_symbol
= s
;
3345 latest_undo_chgset
->syms
.safe_push (sym
);
3349 /* Given a name, find a symbol, or create it if it does not exist yet
3350 in the current namespace. If the symbol is found we make sure that
3353 The integer return code indicates
3355 1 The symbol name was ambiguous
3356 2 The name meant to be established was already host associated.
3358 So if the return value is nonzero, then an error was issued. */
3361 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3362 bool allow_subroutine
)
3367 /* This doesn't usually happen during resolution. */
3369 ns
= gfc_current_ns
;
3371 /* Try to find the symbol in ns. */
3372 st
= gfc_find_symtree (ns
->sym_root
, name
);
3374 if (st
== NULL
&& ns
->omp_udr_ns
)
3377 st
= gfc_find_symtree (ns
->sym_root
, name
);
3382 /* If not there, create a new symbol. */
3383 p
= gfc_new_symbol (name
, ns
);
3385 /* Add to the list of tentative symbols. */
3386 p
->old_symbol
= NULL
;
3389 latest_undo_chgset
->syms
.safe_push (p
);
3391 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3398 /* Make sure the existing symbol is OK. Ambiguous
3399 generic interfaces are permitted, as long as the
3400 specific interfaces are different. */
3401 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3403 ambiguous_symbol (name
, st
);
3408 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3409 && !(allow_subroutine
&& p
->attr
.subroutine
)
3410 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3411 && (ns
->has_import_set
|| p
->attr
.imported
)))
3413 /* Symbol is from another namespace. */
3414 gfc_error ("Symbol %qs at %C has already been host associated",
3421 /* Copy in case this symbol is changed. */
3422 gfc_save_symbol_data (p
);
3431 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3436 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3441 *result
= st
->n
.sym
;
3448 /* Subroutine that searches for a symbol, creating it if it doesn't
3449 exist, but tries to host-associate the symbol if possible. */
3452 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3457 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3461 gfc_save_symbol_data (st
->n
.sym
);
3466 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3476 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3481 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3486 i
= gfc_get_ha_sym_tree (name
, &st
);
3489 *result
= st
->n
.sym
;
3497 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3498 head->name as the common_root symtree's name might be mangled. */
3500 static gfc_symtree
*
3501 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3504 gfc_symtree
*result
;
3509 if (st
->n
.common
== head
)
3512 result
= find_common_symtree (st
->left
, head
);
3514 result
= find_common_symtree (st
->right
, head
);
3520 /* Restore previous state of symbol. Just copy simple stuff. */
3523 restore_old_symbol (gfc_symbol
*p
)
3528 old
= p
->old_symbol
;
3530 p
->ts
.type
= old
->ts
.type
;
3531 p
->ts
.kind
= old
->ts
.kind
;
3533 p
->attr
= old
->attr
;
3535 if (p
->value
!= old
->value
)
3537 gcc_checking_assert (old
->value
== NULL
);
3538 gfc_free_expr (p
->value
);
3542 if (p
->as
!= old
->as
)
3545 gfc_free_array_spec (p
->as
);
3549 p
->generic
= old
->generic
;
3550 p
->component_access
= old
->component_access
;
3552 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3554 gfc_free_namelist (p
->namelist
);
3559 if (p
->namelist_tail
!= old
->namelist_tail
)
3561 gfc_free_namelist (old
->namelist_tail
->next
);
3562 old
->namelist_tail
->next
= NULL
;
3566 p
->namelist_tail
= old
->namelist_tail
;
3568 if (p
->formal
!= old
->formal
)
3570 gfc_free_formal_arglist (p
->formal
);
3571 p
->formal
= old
->formal
;
3574 set_symbol_common_block (p
, old
->common_block
);
3575 p
->common_head
= old
->common_head
;
3577 p
->old_symbol
= old
->old_symbol
;
3582 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3583 the structure itself. */
3586 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3593 /* Given a change set pointer, free its target's contents and update it with
3594 the address of the previous change set. Note that only the contents are
3595 freed, not the target itself (the contents' container). It is not a problem
3596 as the latter will be a local variable usually. */
3599 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3601 free_undo_change_set_data (*cs
);
3606 static void free_old_symbol (gfc_symbol
*sym
);
3609 /* Merges the current change set into the previous one. The changes themselves
3610 are left untouched; only one checkpoint is forgotten. */
3613 gfc_drop_last_undo_checkpoint (void)
3618 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3620 /* No need to loop in this case. */
3621 if (s
->old_symbol
== NULL
)
3624 /* Remove the duplicate symbols. */
3625 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3628 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3630 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3631 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3632 shall contain from now on the backup symbol for S as it was
3633 at the checkpoint before. */
3634 if (s
->old_symbol
->gfc_new
)
3636 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3637 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3638 free_old_symbol (s
);
3641 restore_old_symbol (s
->old_symbol
);
3646 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3647 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3649 pop_undo_change_set (latest_undo_chgset
);
3653 /* Undoes all the changes made to symbols since the previous checkpoint.
3654 This subroutine is made simpler due to the fact that attributes are
3655 never removed once added. */
3658 gfc_restore_last_undo_checkpoint (void)
3663 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3665 /* Symbol in a common block was new. Or was old and just put in common */
3667 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3669 /* If the symbol was added to any common block, it
3670 needs to be removed to stop the resolver looking
3671 for a (possibly) dead symbol. */
3672 if (p
->common_block
->head
== p
&& !p
->common_next
)
3674 gfc_symtree st
, *st0
;
3675 st0
= find_common_symtree (p
->ns
->common_root
,
3679 st
.name
= st0
->name
;
3680 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3685 if (p
->common_block
->head
== p
)
3686 p
->common_block
->head
= p
->common_next
;
3689 gfc_symbol
*cparent
, *csym
;
3691 cparent
= p
->common_block
->head
;
3692 csym
= cparent
->common_next
;
3697 csym
= csym
->common_next
;
3700 gcc_assert(cparent
->common_next
== p
);
3701 cparent
->common_next
= csym
->common_next
;
3703 p
->common_next
= NULL
;
3707 /* The derived type is saved in the symtree with the first
3708 letter capitalized; the all lower-case version to the
3709 derived type contains its associated generic function. */
3710 if (gfc_fl_struct (p
->attr
.flavor
))
3711 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3713 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3715 gfc_release_symbol (p
);
3718 restore_old_symbol (p
);
3721 latest_undo_chgset
->syms
.truncate (0);
3722 latest_undo_chgset
->tbps
.truncate (0);
3724 if (!single_undo_checkpoint_p ())
3725 pop_undo_change_set (latest_undo_chgset
);
3729 /* Makes sure that there is only one set of changes; in other words we haven't
3730 forgotten to pair a call to gfc_new_checkpoint with a call to either
3731 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3734 enforce_single_undo_checkpoint (void)
3736 gcc_checking_assert (single_undo_checkpoint_p ());
3740 /* Undoes all the changes made to symbols in the current statement. */
3743 gfc_undo_symbols (void)
3745 enforce_single_undo_checkpoint ();
3746 gfc_restore_last_undo_checkpoint ();
3750 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3751 components of old_symbol that might need deallocation are the "allocatables"
3752 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3753 namelist_tail. In case these differ between old_symbol and sym, it's just
3754 because sym->namelist has gotten a few more items. */
3757 free_old_symbol (gfc_symbol
*sym
)
3760 if (sym
->old_symbol
== NULL
)
3763 if (sym
->old_symbol
->as
!= sym
->as
)
3764 gfc_free_array_spec (sym
->old_symbol
->as
);
3766 if (sym
->old_symbol
->value
!= sym
->value
)
3767 gfc_free_expr (sym
->old_symbol
->value
);
3769 if (sym
->old_symbol
->formal
!= sym
->formal
)
3770 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3772 free (sym
->old_symbol
);
3773 sym
->old_symbol
= NULL
;
3777 /* Makes the changes made in the current statement permanent-- gets
3778 rid of undo information. */
3781 gfc_commit_symbols (void)
3784 gfc_typebound_proc
*tbp
;
3787 enforce_single_undo_checkpoint ();
3789 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3793 free_old_symbol (p
);
3795 latest_undo_chgset
->syms
.truncate (0);
3797 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3799 latest_undo_chgset
->tbps
.truncate (0);
3803 /* Makes the changes made in one symbol permanent -- gets rid of undo
3807 gfc_commit_symbol (gfc_symbol
*sym
)
3812 enforce_single_undo_checkpoint ();
3814 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3817 latest_undo_chgset
->syms
.unordered_remove (i
);
3824 free_old_symbol (sym
);
3828 /* Recursively free trees containing type-bound procedures. */
3831 free_tb_tree (gfc_symtree
*t
)
3836 free_tb_tree (t
->left
);
3837 free_tb_tree (t
->right
);
3839 /* TODO: Free type-bound procedure structs themselves; probably needs some
3840 sort of ref-counting mechanism. */
3846 /* Recursive function that deletes an entire tree and all the common
3847 head structures it points to. */
3850 free_common_tree (gfc_symtree
* common_tree
)
3852 if (common_tree
== NULL
)
3855 free_common_tree (common_tree
->left
);
3856 free_common_tree (common_tree
->right
);
3862 /* Recursive function that deletes an entire tree and all the common
3863 head structures it points to. */
3866 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3868 if (omp_udr_tree
== NULL
)
3871 free_omp_udr_tree (omp_udr_tree
->left
);
3872 free_omp_udr_tree (omp_udr_tree
->right
);
3874 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3875 free (omp_udr_tree
);
3879 /* Recursive function that deletes an entire tree and all the user
3880 operator nodes that it contains. */
3883 free_uop_tree (gfc_symtree
*uop_tree
)
3885 if (uop_tree
== NULL
)
3888 free_uop_tree (uop_tree
->left
);
3889 free_uop_tree (uop_tree
->right
);
3891 gfc_free_interface (uop_tree
->n
.uop
->op
);
3892 free (uop_tree
->n
.uop
);
3897 /* Recursive function that deletes an entire tree and all the symbols
3898 that it contains. */
3901 free_sym_tree (gfc_symtree
*sym_tree
)
3903 if (sym_tree
== NULL
)
3906 free_sym_tree (sym_tree
->left
);
3907 free_sym_tree (sym_tree
->right
);
3909 gfc_release_symbol (sym_tree
->n
.sym
);
3914 /* Free the gfc_equiv_info's. */
3917 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3921 gfc_free_equiv_infos (s
->next
);
3926 /* Free the gfc_equiv_lists. */
3929 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3933 gfc_free_equiv_lists (l
->next
);
3934 gfc_free_equiv_infos (l
->equiv
);
3939 /* Free a finalizer procedure list. */
3942 gfc_free_finalizer (gfc_finalizer
* el
)
3946 gfc_release_symbol (el
->proc_sym
);
3952 gfc_free_finalizer_list (gfc_finalizer
* list
)
3956 gfc_finalizer
* current
= list
;
3958 gfc_free_finalizer (current
);
3963 /* Create a new gfc_charlen structure and add it to a namespace.
3964 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3967 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3971 cl
= gfc_get_charlen ();
3976 cl
->length
= gfc_copy_expr (old_cl
->length
);
3977 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3978 cl
->backend_decl
= old_cl
->backend_decl
;
3979 cl
->passed_length
= old_cl
->passed_length
;
3980 cl
->resolved
= old_cl
->resolved
;
3983 /* Put into namespace. */
3984 cl
->next
= ns
->cl_list
;
3991 /* Free the charlen list from cl to end (end is not freed).
3992 Free the whole list if end is NULL. */
3995 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3999 for (; cl
!= end
; cl
= cl2
)
4004 gfc_free_expr (cl
->length
);
4010 /* Free entry list structs. */
4013 free_entry_list (gfc_entry_list
*el
)
4015 gfc_entry_list
*next
;
4022 free_entry_list (next
);
4026 /* Free a namespace structure and everything below it. Interface
4027 lists associated with intrinsic operators are not freed. These are
4028 taken care of when a specific name is freed. */
4031 gfc_free_namespace (gfc_namespace
*ns
)
4033 gfc_namespace
*p
, *q
;
4043 gcc_assert (ns
->refs
== 0);
4045 gfc_free_statements (ns
->code
);
4047 free_sym_tree (ns
->sym_root
);
4048 free_uop_tree (ns
->uop_root
);
4049 free_common_tree (ns
->common_root
);
4050 free_omp_udr_tree (ns
->omp_udr_root
);
4051 free_tb_tree (ns
->tb_sym_root
);
4052 free_tb_tree (ns
->tb_uop_root
);
4053 gfc_free_finalizer_list (ns
->finalizers
);
4054 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4055 gfc_free_charlen (ns
->cl_list
, NULL
);
4056 free_st_labels (ns
->st_labels
);
4058 free_entry_list (ns
->entries
);
4059 gfc_free_equiv (ns
->equiv
);
4060 gfc_free_equiv_lists (ns
->equiv_lists
);
4061 gfc_free_use_stmts (ns
->use_stmts
);
4063 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4064 gfc_free_interface (ns
->op
[i
]);
4066 gfc_free_data (ns
->data
);
4070 /* Recursively free any contained namespaces. */
4075 gfc_free_namespace (q
);
4081 gfc_symbol_init_2 (void)
4084 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4089 gfc_symbol_done_2 (void)
4091 if (gfc_current_ns
!= NULL
)
4093 /* free everything from the root. */
4094 while (gfc_current_ns
->parent
!= NULL
)
4095 gfc_current_ns
= gfc_current_ns
->parent
;
4096 gfc_free_namespace (gfc_current_ns
);
4097 gfc_current_ns
= NULL
;
4099 gfc_derived_types
= NULL
;
4101 enforce_single_undo_checkpoint ();
4102 free_undo_change_set_data (*latest_undo_chgset
);
4106 /* Count how many nodes a symtree has. */
4109 count_st_nodes (const gfc_symtree
*st
)
4115 nodes
= count_st_nodes (st
->left
);
4117 nodes
+= count_st_nodes (st
->right
);
4123 /* Convert symtree tree into symtree vector. */
4126 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4131 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4132 st_vec
[node_cntr
++] = st
;
4133 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4139 /* Traverse namespace. As the functions might modify the symtree, we store the
4140 symtree as a vector and operate on this vector. Note: We assume that
4141 sym_func or st_func never deletes nodes from the symtree - only adding is
4142 allowed. Additionally, newly added nodes are not traversed. */
4145 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4146 void (*sym_func
) (gfc_symbol
*))
4148 gfc_symtree
**st_vec
;
4149 unsigned nodes
, i
, node_cntr
;
4151 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4152 nodes
= count_st_nodes (st
);
4153 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4155 fill_st_vector (st
, st_vec
, node_cntr
);
4160 for (i
= 0; i
< nodes
; i
++)
4161 st_vec
[i
]->n
.sym
->mark
= 0;
4162 for (i
= 0; i
< nodes
; i
++)
4163 if (!st_vec
[i
]->n
.sym
->mark
)
4165 (*sym_func
) (st_vec
[i
]->n
.sym
);
4166 st_vec
[i
]->n
.sym
->mark
= 1;
4170 for (i
= 0; i
< nodes
; i
++)
4171 (*st_func
) (st_vec
[i
]);
4175 /* Recursively traverse the symtree nodes. */
4178 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4180 do_traverse_symtree (st
, st_func
, NULL
);
4184 /* Call a given function for all symbols in the namespace. We take
4185 care that each gfc_symbol node is called exactly once. */
4188 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4190 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4194 /* Return TRUE when name is the name of an intrinsic type. */
4197 gfc_is_intrinsic_typename (const char *name
)
4199 if (strcmp (name
, "integer") == 0
4200 || strcmp (name
, "real") == 0
4201 || strcmp (name
, "character") == 0
4202 || strcmp (name
, "logical") == 0
4203 || strcmp (name
, "complex") == 0
4204 || strcmp (name
, "doubleprecision") == 0
4205 || strcmp (name
, "doublecomplex") == 0)
4212 /* Return TRUE if the symbol is an automatic variable. */
4215 gfc_is_var_automatic (gfc_symbol
*sym
)
4217 /* Pointer and allocatable variables are never automatic. */
4218 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4220 /* Check for arrays with non-constant size. */
4221 if (sym
->attr
.dimension
&& sym
->as
4222 && !gfc_is_compile_time_shape (sym
->as
))
4224 /* Check for non-constant length character variables. */
4225 if (sym
->ts
.type
== BT_CHARACTER
4227 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4229 /* Variables with explicit AUTOMATIC attribute. */
4230 if (sym
->attr
.automatic
)
4236 /* Given a symbol, mark it as SAVEd if it is allowed. */
4239 save_symbol (gfc_symbol
*sym
)
4242 if (sym
->attr
.use_assoc
)
4245 if (sym
->attr
.in_common
4246 || sym
->attr
.in_equivalence
4249 || sym
->attr
.flavor
!= FL_VARIABLE
)
4251 /* Automatic objects are not saved. */
4252 if (gfc_is_var_automatic (sym
))
4254 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4258 /* Mark those symbols which can be SAVEd as such. */
4261 gfc_save_all (gfc_namespace
*ns
)
4263 gfc_traverse_ns (ns
, save_symbol
);
4267 /* Make sure that no changes to symbols are pending. */
4270 gfc_enforce_clean_symbol_state(void)
4272 enforce_single_undo_checkpoint ();
4273 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4277 /************** Global symbol handling ************/
4280 /* Search a tree for the global symbol. */
4283 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4292 c
= strcmp (name
, symbol
->name
);
4296 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4303 /* Case insensitive search a tree for the global symbol. */
4306 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4315 c
= strcasecmp (name
, symbol
->name
);
4319 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4326 /* Compare two global symbols. Used for managing the BB tree. */
4329 gsym_compare (void *_s1
, void *_s2
)
4331 gfc_gsymbol
*s1
, *s2
;
4333 s1
= (gfc_gsymbol
*) _s1
;
4334 s2
= (gfc_gsymbol
*) _s2
;
4335 return strcmp (s1
->name
, s2
->name
);
4339 /* Get a global symbol, creating it if it doesn't exist. */
4342 gfc_get_gsymbol (const char *name
, bool bind_c
)
4346 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4350 s
= XCNEW (gfc_gsymbol
);
4351 s
->type
= GSYM_UNKNOWN
;
4352 s
->name
= gfc_get_string ("%s", name
);
4355 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4361 gfc_traverse_gsymbol (gfc_gsymbol
*gsym
,
4362 void (*do_something
) (gfc_gsymbol
*, void *),
4366 gfc_traverse_gsymbol (gsym
->left
, do_something
, data
);
4368 (*do_something
) (gsym
, data
);
4371 gfc_traverse_gsymbol (gsym
->right
, do_something
, data
);
4375 get_iso_c_binding_dt (int sym_id
)
4377 gfc_symbol
*dt_list
= gfc_derived_types
;
4379 /* Loop through the derived types in the name list, searching for
4380 the desired symbol from iso_c_binding. Search the parent namespaces
4381 if necessary and requested to (parent_flag). */
4384 while (dt_list
->dt_next
!= gfc_derived_types
)
4386 if (dt_list
->from_intmod
!= INTMOD_NONE
4387 && dt_list
->intmod_sym_id
== sym_id
)
4390 dt_list
= dt_list
->dt_next
;
4398 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4399 with C. This is necessary for any derived type that is BIND(C) and for
4400 derived types that are parameters to functions that are BIND(C). All
4401 fields of the derived type are required to be interoperable, and are tested
4402 for such. If an error occurs, the errors are reported here, allowing for
4403 multiple errors to be handled for a single derived type. */
4406 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4408 gfc_component
*curr_comp
= NULL
;
4409 bool is_c_interop
= false;
4412 if (derived_sym
== NULL
)
4413 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4414 "unexpectedly NULL");
4416 /* If we've already looked at this derived symbol, do not look at it again
4417 so we don't repeat warnings/errors. */
4418 if (derived_sym
->ts
.is_c_interop
)
4421 /* The derived type must have the BIND attribute to be interoperable
4422 J3/04-007, Section 15.2.3. */
4423 if (derived_sym
->attr
.is_bind_c
!= 1)
4425 derived_sym
->ts
.is_c_interop
= 0;
4426 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4427 "attribute to be C interoperable", derived_sym
->name
,
4428 &(derived_sym
->declared_at
));
4432 curr_comp
= derived_sym
->components
;
4434 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4435 empty struct. Section 15.2 in Fortran 2003 states: "The following
4436 subclauses define the conditions under which a Fortran entity is
4437 interoperable. If a Fortran entity is interoperable, an equivalent
4438 entity may be defined by means of C and the Fortran entity is said
4439 to be interoperable with the C entity. There does not have to be such
4440 an interoperating C entity."
4442 if (curr_comp
== NULL
)
4444 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4445 "and may be inaccessible by the C companion processor",
4446 derived_sym
->name
, &(derived_sym
->declared_at
));
4447 derived_sym
->ts
.is_c_interop
= 1;
4448 derived_sym
->attr
.is_bind_c
= 1;
4453 /* Initialize the derived type as being C interoperable.
4454 If we find an error in the components, this will be set false. */
4455 derived_sym
->ts
.is_c_interop
= 1;
4457 /* Loop through the list of components to verify that the kind of
4458 each is a C interoperable type. */
4461 /* The components cannot be pointers (fortran sense).
4462 J3/04-007, Section 15.2.3, C1505. */
4463 if (curr_comp
->attr
.pointer
!= 0)
4465 gfc_error ("Component %qs at %L cannot have the "
4466 "POINTER attribute because it is a member "
4467 "of the BIND(C) derived type %qs at %L",
4468 curr_comp
->name
, &(curr_comp
->loc
),
4469 derived_sym
->name
, &(derived_sym
->declared_at
));
4473 if (curr_comp
->attr
.proc_pointer
!= 0)
4475 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4476 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4477 &curr_comp
->loc
, derived_sym
->name
,
4478 &derived_sym
->declared_at
);
4482 /* The components cannot be allocatable.
4483 J3/04-007, Section 15.2.3, C1505. */
4484 if (curr_comp
->attr
.allocatable
!= 0)
4486 gfc_error ("Component %qs at %L cannot have the "
4487 "ALLOCATABLE attribute because it is a member "
4488 "of the BIND(C) derived type %qs at %L",
4489 curr_comp
->name
, &(curr_comp
->loc
),
4490 derived_sym
->name
, &(derived_sym
->declared_at
));
4494 /* BIND(C) derived types must have interoperable components. */
4495 if (curr_comp
->ts
.type
== BT_DERIVED
4496 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4497 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4499 /* This should be allowed; the draft says a derived-type cannot
4500 have type parameters if it is has the BIND attribute. Type
4501 parameters seem to be for making parameterized derived types.
4502 There's no need to verify the type if it is c_ptr/c_funptr. */
4503 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4507 /* Grab the typespec for the given component and test the kind. */
4508 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4512 /* Report warning and continue since not fatal. The
4513 draft does specify a constraint that requires all fields
4514 to interoperate, but if the user says real(4), etc., it
4515 may interoperate with *something* in C, but the compiler
4516 most likely won't know exactly what. Further, it may not
4517 interoperate with the same data type(s) in C if the user
4518 recompiles with different flags (e.g., -m32 and -m64 on
4519 x86_64 and using integer(4) to claim interop with a
4521 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4522 /* If the derived type is bind(c), all fields must be
4524 gfc_warning (OPT_Wc_binding_type
,
4525 "Component %qs in derived type %qs at %L "
4526 "may not be C interoperable, even though "
4527 "derived type %qs is BIND(C)",
4528 curr_comp
->name
, derived_sym
->name
,
4529 &(curr_comp
->loc
), derived_sym
->name
);
4530 else if (warn_c_binding_type
)
4531 /* If derived type is param to bind(c) routine, or to one
4532 of the iso_c_binding procs, it must be interoperable, so
4533 all fields must interop too. */
4534 gfc_warning (OPT_Wc_binding_type
,
4535 "Component %qs in derived type %qs at %L "
4536 "may not be C interoperable",
4537 curr_comp
->name
, derived_sym
->name
,
4542 curr_comp
= curr_comp
->next
;
4543 } while (curr_comp
!= NULL
);
4545 if (derived_sym
->attr
.sequence
!= 0)
4547 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4548 "attribute because it is BIND(C)", derived_sym
->name
,
4549 &(derived_sym
->declared_at
));
4553 /* Mark the derived type as not being C interoperable if we found an
4554 error. If there were only warnings, proceed with the assumption
4555 it's interoperable. */
4557 derived_sym
->ts
.is_c_interop
= 0;
4563 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4566 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4570 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4571 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4573 tmp_sym
->attr
.is_c_interop
= 1;
4574 tmp_sym
->attr
.is_bind_c
= 1;
4575 tmp_sym
->ts
.is_c_interop
= 1;
4576 tmp_sym
->ts
.is_iso_c
= 1;
4577 tmp_sym
->ts
.type
= BT_DERIVED
;
4578 tmp_sym
->ts
.f90_type
= BT_VOID
;
4579 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4580 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4582 /* Set the c_address field of c_null_ptr and c_null_funptr to
4583 the value of NULL. */
4584 tmp_sym
->value
= gfc_get_expr ();
4585 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4586 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4587 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4588 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4589 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4590 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4591 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4592 c
->expr
->ts
.is_iso_c
= 1;
4598 /* Add a formal argument, gfc_formal_arglist, to the
4599 end of the given list of arguments. Set the reference to the
4600 provided symbol, param_sym, in the argument. */
4603 add_formal_arg (gfc_formal_arglist
**head
,
4604 gfc_formal_arglist
**tail
,
4605 gfc_formal_arglist
*formal_arg
,
4606 gfc_symbol
*param_sym
)
4608 /* Put in list, either as first arg or at the tail (curr arg). */
4610 *head
= *tail
= formal_arg
;
4613 (*tail
)->next
= formal_arg
;
4614 (*tail
) = formal_arg
;
4617 (*tail
)->sym
= param_sym
;
4618 (*tail
)->next
= NULL
;
4624 /* Add a procedure interface to the given symbol (i.e., store a
4625 reference to the list of formal arguments). */
4628 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4631 sym
->formal
= formal
;
4632 sym
->attr
.if_source
= source
;
4636 /* Copy the formal args from an existing symbol, src, into a new
4637 symbol, dest. New formal args are created, and the description of
4638 each arg is set according to the existing ones. This function is
4639 used when creating procedure declaration variables from a procedure
4640 declaration statement (see match_proc_decl()) to create the formal
4641 args based on the args of a given named interface.
4643 When an actual argument list is provided, skip the absent arguments.
4644 To be used together with gfc_se->ignore_optional. */
4647 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4648 gfc_actual_arglist
*actual
)
4650 gfc_formal_arglist
*head
= NULL
;
4651 gfc_formal_arglist
*tail
= NULL
;
4652 gfc_formal_arglist
*formal_arg
= NULL
;
4653 gfc_intrinsic_arg
*curr_arg
= NULL
;
4654 gfc_formal_arglist
*formal_prev
= NULL
;
4655 gfc_actual_arglist
*act_arg
= actual
;
4656 /* Save current namespace so we can change it for formal args. */
4657 gfc_namespace
*parent_ns
= gfc_current_ns
;
4659 /* Create a new namespace, which will be the formal ns (namespace
4660 of the formal args). */
4661 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4662 gfc_current_ns
->proc_name
= dest
;
4664 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4666 /* Skip absent arguments. */
4669 gcc_assert (act_arg
!= NULL
);
4670 if (act_arg
->expr
== NULL
)
4672 act_arg
= act_arg
->next
;
4675 act_arg
= act_arg
->next
;
4677 formal_arg
= gfc_get_formal_arglist ();
4678 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4680 /* May need to copy more info for the symbol. */
4681 formal_arg
->sym
->ts
= curr_arg
->ts
;
4682 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4683 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4684 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4685 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4686 formal_arg
->sym
->attr
.dummy
= 1;
4688 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4689 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4691 /* If this isn't the first arg, set up the next ptr. For the
4692 last arg built, the formal_arg->next will never get set to
4693 anything other than NULL. */
4694 if (formal_prev
!= NULL
)
4695 formal_prev
->next
= formal_arg
;
4697 formal_arg
->next
= NULL
;
4699 formal_prev
= formal_arg
;
4701 /* Add arg to list of formal args. */
4702 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4704 /* Validate changes. */
4705 gfc_commit_symbol (formal_arg
->sym
);
4708 /* Add the interface to the symbol. */
4709 add_proc_interface (dest
, IFSRC_DECL
, head
);
4711 /* Store the formal namespace information. */
4712 if (dest
->formal
!= NULL
)
4713 /* The current ns should be that for the dest proc. */
4714 dest
->formal_ns
= gfc_current_ns
;
4715 /* Restore the current namespace to what it was on entry. */
4716 gfc_current_ns
= parent_ns
;
4721 std_for_isocbinding_symbol (int id
)
4725 #define NAMED_INTCST(a,b,c,d) \
4728 #include "iso-c-binding.def"
4731 #define NAMED_FUNCTION(a,b,c,d) \
4734 #define NAMED_SUBROUTINE(a,b,c,d) \
4737 #include "iso-c-binding.def"
4738 #undef NAMED_FUNCTION
4739 #undef NAMED_SUBROUTINE
4742 return GFC_STD_F2003
;
4746 /* Generate the given set of C interoperable kind objects, or all
4747 interoperable kinds. This function will only be given kind objects
4748 for valid iso_c_binding defined types because this is verified when
4749 the 'use' statement is parsed. If the user gives an 'only' clause,
4750 the specific kinds are looked up; if they don't exist, an error is
4751 reported. If the user does not give an 'only' clause, all
4752 iso_c_binding symbols are generated. If a list of specific kinds
4753 is given, it must have a NULL in the first empty spot to mark the
4754 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4755 point to the symtree for c_(fun)ptr. */
4758 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4759 const char *local_name
, gfc_symtree
*dt_symtree
,
4762 const char *const name
= (local_name
&& local_name
[0])
4763 ? local_name
: c_interop_kinds_table
[s
].name
;
4764 gfc_symtree
*tmp_symtree
;
4765 gfc_symbol
*tmp_sym
= NULL
;
4768 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4771 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4773 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4774 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4775 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4778 /* Already exists in this scope so don't re-add it. */
4779 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4780 && (!tmp_sym
->attr
.generic
4781 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4782 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4784 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4785 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4787 if (gfc_derived_types
)
4789 tmp_sym
->dt_next
= gfc_derived_types
->dt_next
;
4790 gfc_derived_types
->dt_next
= tmp_sym
;
4794 tmp_sym
->dt_next
= tmp_sym
;
4796 gfc_derived_types
= tmp_sym
;
4802 /* Create the sym tree in the current ns. */
4805 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4806 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4808 /* Add to the list of tentative symbols. */
4809 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4810 tmp_sym
->old_symbol
= NULL
;
4812 tmp_sym
->gfc_new
= 1;
4814 tmp_symtree
->n
.sym
= tmp_sym
;
4819 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4820 gcc_assert (tmp_symtree
);
4821 tmp_sym
= tmp_symtree
->n
.sym
;
4824 /* Say what module this symbol belongs to. */
4825 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4826 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4827 tmp_sym
->intmod_sym_id
= s
;
4828 tmp_sym
->attr
.is_iso_c
= 1;
4829 tmp_sym
->attr
.use_assoc
= 1;
4831 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4832 || s
== ISOCBINDING_NULL_PTR
);
4837 #define NAMED_INTCST(a,b,c,d) case a :
4838 #define NAMED_REALCST(a,b,c,d) case a :
4839 #define NAMED_CMPXCST(a,b,c,d) case a :
4840 #define NAMED_LOGCST(a,b,c) case a :
4841 #define NAMED_CHARKNDCST(a,b,c) case a :
4842 #include "iso-c-binding.def"
4844 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4845 c_interop_kinds_table
[s
].value
);
4847 /* Initialize an integer constant expression node. */
4848 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4849 tmp_sym
->ts
.type
= BT_INTEGER
;
4850 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4852 /* Mark this type as a C interoperable one. */
4853 tmp_sym
->ts
.is_c_interop
= 1;
4854 tmp_sym
->ts
.is_iso_c
= 1;
4855 tmp_sym
->value
->ts
.is_c_interop
= 1;
4856 tmp_sym
->value
->ts
.is_iso_c
= 1;
4857 tmp_sym
->attr
.is_c_interop
= 1;
4859 /* Tell what f90 type this c interop kind is valid. */
4860 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4865 #define NAMED_CHARCST(a,b,c) case a :
4866 #include "iso-c-binding.def"
4868 /* Initialize an integer constant expression node for the
4869 length of the character. */
4870 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4871 &gfc_current_locus
, NULL
, 1);
4872 tmp_sym
->value
->ts
.is_c_interop
= 1;
4873 tmp_sym
->value
->ts
.is_iso_c
= 1;
4874 tmp_sym
->value
->value
.character
.length
= 1;
4875 tmp_sym
->value
->value
.character
.string
[0]
4876 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4877 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4878 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4881 /* May not need this in both attr and ts, but do need in
4882 attr for writing module file. */
4883 tmp_sym
->attr
.is_c_interop
= 1;
4885 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4886 tmp_sym
->ts
.type
= BT_CHARACTER
;
4888 /* Need to set it to the C_CHAR kind. */
4889 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4891 /* Mark this type as a C interoperable one. */
4892 tmp_sym
->ts
.is_c_interop
= 1;
4893 tmp_sym
->ts
.is_iso_c
= 1;
4895 /* Tell what f90 type this c interop kind is valid. */
4896 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4900 case ISOCBINDING_PTR
:
4901 case ISOCBINDING_FUNPTR
:
4904 gfc_component
*tmp_comp
= NULL
;
4906 /* Generate real derived type. */
4911 const char *hidden_name
;
4912 gfc_interface
*intr
, *head
;
4914 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4915 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4917 gcc_assert (tmp_symtree
== NULL
);
4918 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4919 dt_sym
= tmp_symtree
->n
.sym
;
4920 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4921 ? "c_ptr" : "c_funptr");
4923 /* Generate an artificial generic function. */
4924 head
= tmp_sym
->generic
;
4925 intr
= gfc_get_interface ();
4927 intr
->where
= gfc_current_locus
;
4929 tmp_sym
->generic
= intr
;
4931 if (!tmp_sym
->attr
.generic
4932 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4935 if (!tmp_sym
->attr
.function
4936 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4940 /* Say what module this symbol belongs to. */
4941 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4942 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4943 dt_sym
->intmod_sym_id
= s
;
4944 dt_sym
->attr
.use_assoc
= 1;
4946 /* Initialize an integer constant expression node. */
4947 dt_sym
->attr
.flavor
= FL_DERIVED
;
4948 dt_sym
->ts
.is_c_interop
= 1;
4949 dt_sym
->attr
.is_c_interop
= 1;
4950 dt_sym
->attr
.private_comp
= 1;
4951 dt_sym
->component_access
= ACCESS_PRIVATE
;
4952 dt_sym
->ts
.is_iso_c
= 1;
4953 dt_sym
->ts
.type
= BT_DERIVED
;
4954 dt_sym
->ts
.f90_type
= BT_VOID
;
4956 /* A derived type must have the bind attribute to be
4957 interoperable (J3/04-007, Section 15.2.3), even though
4958 the binding label is not used. */
4959 dt_sym
->attr
.is_bind_c
= 1;
4961 dt_sym
->attr
.referenced
= 1;
4962 dt_sym
->ts
.u
.derived
= dt_sym
;
4964 /* Add the symbol created for the derived type to the current ns. */
4965 if (gfc_derived_types
)
4967 dt_sym
->dt_next
= gfc_derived_types
->dt_next
;
4968 gfc_derived_types
->dt_next
= dt_sym
;
4972 dt_sym
->dt_next
= dt_sym
;
4974 gfc_derived_types
= dt_sym
;
4976 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4977 if (tmp_comp
== NULL
)
4980 tmp_comp
->ts
.type
= BT_INTEGER
;
4982 /* Set this because the module will need to read/write this field. */
4983 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4985 /* The kinds for c_ptr and c_funptr are the same. */
4986 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4987 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4988 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4990 /* Mark the component as C interoperable. */
4991 tmp_comp
->ts
.is_c_interop
= 1;
4996 case ISOCBINDING_NULL_PTR
:
4997 case ISOCBINDING_NULL_FUNPTR
:
4998 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
5004 gfc_commit_symbol (tmp_sym
);
5009 /* Check that a symbol is already typed. If strict is not set, an untyped
5010 symbol is acceptable for non-standard-conforming mode. */
5013 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5014 bool strict
, locus where
)
5018 if (gfc_matching_prefix
)
5021 /* Check for the type and try to give it an implicit one. */
5022 if (sym
->ts
.type
== BT_UNKNOWN
5023 && !gfc_set_default_type (sym
, 0, ns
))
5027 gfc_error ("Symbol %qs is used before it is typed at %L",
5032 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5033 " it is typed at %L", sym
->name
, &where
))
5037 /* Everything is ok. */
5042 /* Construct a typebound-procedure structure. Those are stored in a tentative
5043 list and marked `error' until symbols are committed. */
5046 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5048 gfc_typebound_proc
*result
;
5050 result
= XCNEW (gfc_typebound_proc
);
5055 latest_undo_chgset
->tbps
.safe_push (result
);
5061 /* Get the super-type of a given derived type. */
5064 gfc_get_derived_super_type (gfc_symbol
* derived
)
5066 gcc_assert (derived
);
5068 if (derived
->attr
.generic
)
5069 derived
= gfc_find_dt_in_generic (derived
);
5071 if (!derived
->attr
.extension
)
5074 gcc_assert (derived
->components
);
5075 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5076 gcc_assert (derived
->components
->ts
.u
.derived
);
5078 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5079 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5081 return derived
->components
->ts
.u
.derived
;
5085 /* Get the ultimate super-type of a given derived type. */
5088 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
5090 if (!derived
->attr
.extension
)
5093 derived
= gfc_get_derived_super_type (derived
);
5095 if (derived
->attr
.extension
)
5096 return gfc_get_ultimate_derived_super_type (derived
);
5102 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5105 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5107 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5108 t2
= gfc_get_derived_super_type (t2
);
5109 return gfc_compare_derived_types (t1
, t2
);
5113 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5114 If ts1 is nonpolymorphic, ts2 must be the same type.
5115 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5118 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5120 bool is_class1
= (ts1
->type
== BT_CLASS
);
5121 bool is_class2
= (ts2
->type
== BT_CLASS
);
5122 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5123 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5124 bool is_union1
= (ts1
->type
== BT_UNION
);
5125 bool is_union2
= (ts2
->type
== BT_UNION
);
5128 && ts1
->u
.derived
->components
5129 && ((ts1
->u
.derived
->attr
.is_class
5130 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5131 .unlimited_polymorphic
)
5132 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5135 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5136 && !is_union1
&& !is_union2
)
5137 return (ts1
->type
== ts2
->type
);
5139 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5140 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5142 if (is_derived1
&& is_class2
)
5143 return gfc_compare_derived_types (ts1
->u
.derived
,
5144 ts2
->u
.derived
->attr
.is_class
?
5145 ts2
->u
.derived
->components
->ts
.u
.derived
5147 if (is_class1
&& is_derived2
)
5148 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5149 ts1
->u
.derived
->components
->ts
.u
.derived
5152 else if (is_class1
&& is_class2
)
5153 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5154 ts1
->u
.derived
->components
->ts
.u
.derived
5156 ts2
->u
.derived
->attr
.is_class
?
5157 ts2
->u
.derived
->components
->ts
.u
.derived
5164 /* Find the parent-namespace of the current function. If we're inside
5165 BLOCK constructs, it may not be the current one. */
5168 gfc_find_proc_namespace (gfc_namespace
* ns
)
5170 while (ns
->construct_entities
)
5180 /* Check if an associate-variable should be translated as an `implicit' pointer
5181 internally (if it is associated to a variable and not an array with
5185 gfc_is_associate_pointer (gfc_symbol
* sym
)
5190 if (sym
->ts
.type
== BT_CLASS
)
5193 if (sym
->ts
.type
== BT_CHARACTER
5195 && sym
->assoc
->target
5196 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5199 if (!sym
->assoc
->variable
)
5202 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5210 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5212 gfc_interface
*intr
= NULL
;
5214 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5217 if (sym
->attr
.generic
)
5218 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5219 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5221 return intr
? intr
->sym
: NULL
;
5225 /* Get the dummy arguments from a procedure symbol. If it has been declared
5226 via a PROCEDURE statement with a named interface, ts.interface will be set
5227 and the arguments need to be taken from there. */
5229 gfc_formal_arglist
*
5230 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5232 gfc_formal_arglist
*dummies
;
5234 dummies
= sym
->formal
;
5235 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5236 dummies
= sym
->ts
.interface
->formal
;