1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2023 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
&& !gfc_query_suppress_errors ())
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.cc(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_std (elemental
, recursive
, GFC_STD_F2018
);
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
)
723 conf (pdt_len
, pdt_kind
)
725 if (attr
->access
== ACCESS_PRIVATE
)
732 a1
= gfc_code2string (flavors
, attr
->flavor
);
734 if (attr
->in_namelist
735 && attr
->flavor
!= FL_VARIABLE
736 && attr
->flavor
!= FL_PROCEDURE
737 && attr
->flavor
!= FL_UNKNOWN
)
743 switch (attr
->flavor
)
753 conf2 (asynchronous
);
756 conf2 (is_protected
);
766 conf2 (threadprivate
);
767 conf2 (omp_declare_target
);
768 conf2 (omp_declare_target_link
);
769 conf2 (oacc_declare_create
);
770 conf2 (oacc_declare_copyin
);
771 conf2 (oacc_declare_deviceptr
);
772 conf2 (oacc_declare_device_resident
);
774 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
776 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
777 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
784 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
798 /* Conflicts with INTENT, SAVE and RESULT will be checked
799 at resolution stage, see "resolve_fl_procedure". */
801 if (attr
->subroutine
)
807 conf2 (asynchronous
);
812 if (!attr
->proc_pointer
)
813 conf2 (threadprivate
);
816 /* Procedure pointers in COMMON blocks are allowed in F03,
817 * but forbidden per F08:C5100. */
818 if (!attr
->proc_pointer
|| (gfc_option
.allow_std
& GFC_STD_F2008
))
821 conf2 (omp_declare_target_link
);
825 case PROC_ST_FUNCTION
:
836 conf2 (threadprivate
);
856 conf2 (threadprivate
);
858 conf2 (omp_declare_target
);
859 conf2 (omp_declare_target_link
);
860 conf2 (oacc_declare_create
);
861 conf2 (oacc_declare_copyin
);
862 conf2 (oacc_declare_deviceptr
);
863 conf2 (oacc_declare_device_resident
);
865 if (attr
->intent
!= INTENT_UNKNOWN
)
882 conf2 (is_protected
);
888 conf2 (asynchronous
);
889 conf2 (threadprivate
);
905 gfc_error ("%s attribute conflicts with %s attribute at %L",
908 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
909 a1
, a2
, name
, where
);
916 return gfc_notify_std (standard
, "%s attribute conflicts "
917 "with %s attribute at %L", a1
, a2
,
922 return gfc_notify_std (standard
, "%s attribute conflicts "
923 "with %s attribute in %qs at %L",
924 a1
, a2
, name
, where
);
933 /* Mark a symbol as referenced. */
936 gfc_set_sym_referenced (gfc_symbol
*sym
)
939 if (sym
->attr
.referenced
)
942 sym
->attr
.referenced
= 1;
944 /* Remember which order dummy variables are accessed in. */
946 sym
->dummy_order
= next_dummy_order
++;
950 /* Common subroutine called by attribute changing subroutines in order
951 to prevent them from changing a symbol that has been
952 use-associated. Returns zero if it is OK to change the symbol,
956 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
959 if (attr
->use_assoc
== 0)
963 where
= &gfc_current_locus
;
966 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
969 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
976 /* Generate an error because of a duplicate attribute. */
979 duplicate_attr (const char *attr
, locus
*where
)
983 where
= &gfc_current_locus
;
985 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
990 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
991 locus
*where ATTRIBUTE_UNUSED
)
993 attr
->ext_attr
|= 1 << ext_attr
;
998 /* Called from decl.cc (attr_decl1) to check attributes, when declared
1002 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
1004 if (check_used (attr
, NULL
, where
))
1007 return gfc_check_conflict (attr
, NULL
, where
);
1012 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
1015 if (check_used (attr
, NULL
, where
))
1018 if (attr
->allocatable
&& ! gfc_submodule_procedure(attr
))
1020 duplicate_attr ("ALLOCATABLE", where
);
1024 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1025 && !gfc_find_state (COMP_INTERFACE
))
1027 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1032 attr
->allocatable
= 1;
1033 return gfc_check_conflict (attr
, NULL
, where
);
1038 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1040 if (check_used (attr
, name
, where
))
1043 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
1044 "Duplicate AUTOMATIC attribute specified at %L", where
))
1047 attr
->automatic
= 1;
1048 return gfc_check_conflict (attr
, name
, where
);
1053 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1056 if (check_used (attr
, name
, where
))
1059 if (attr
->codimension
)
1061 duplicate_attr ("CODIMENSION", where
);
1065 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1066 && !gfc_find_state (COMP_INTERFACE
))
1068 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1069 "at %L", name
, where
);
1073 attr
->codimension
= 1;
1074 return gfc_check_conflict (attr
, name
, where
);
1079 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1082 if (check_used (attr
, name
, where
))
1085 if (attr
->dimension
&& ! gfc_submodule_procedure(attr
))
1087 duplicate_attr ("DIMENSION", where
);
1091 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1092 && !gfc_find_state (COMP_INTERFACE
))
1094 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1095 "at %L", name
, where
);
1099 attr
->dimension
= 1;
1100 return gfc_check_conflict (attr
, name
, where
);
1105 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1108 if (check_used (attr
, name
, where
))
1111 if (attr
->contiguous
)
1113 duplicate_attr ("CONTIGUOUS", where
);
1117 attr
->contiguous
= 1;
1118 return gfc_check_conflict (attr
, name
, where
);
1123 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1126 if (check_used (attr
, NULL
, where
))
1131 duplicate_attr ("EXTERNAL", where
);
1135 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1138 attr
->proc_pointer
= 1;
1143 return gfc_check_conflict (attr
, NULL
, where
);
1148 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1151 if (check_used (attr
, NULL
, where
))
1154 if (attr
->intrinsic
)
1156 duplicate_attr ("INTRINSIC", where
);
1160 attr
->intrinsic
= 1;
1162 return gfc_check_conflict (attr
, NULL
, where
);
1167 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1170 if (check_used (attr
, NULL
, where
))
1175 duplicate_attr ("OPTIONAL", where
);
1180 return gfc_check_conflict (attr
, NULL
, where
);
1184 gfc_add_kind (symbol_attribute
*attr
, locus
*where
)
1188 duplicate_attr ("KIND", where
);
1193 return gfc_check_conflict (attr
, NULL
, where
);
1197 gfc_add_len (symbol_attribute
*attr
, locus
*where
)
1201 duplicate_attr ("LEN", where
);
1206 return gfc_check_conflict (attr
, NULL
, where
);
1211 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1214 if (check_used (attr
, NULL
, where
))
1217 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1218 && !gfc_find_state (COMP_INTERFACE
))
1219 && ! gfc_submodule_procedure(attr
))
1221 duplicate_attr ("POINTER", where
);
1225 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1226 || (attr
->if_source
== IFSRC_IFBODY
1227 && !gfc_find_state (COMP_INTERFACE
)))
1228 attr
->proc_pointer
= 1;
1232 return gfc_check_conflict (attr
, NULL
, where
);
1237 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1240 if (check_used (attr
, NULL
, where
))
1243 attr
->cray_pointer
= 1;
1244 return gfc_check_conflict (attr
, NULL
, where
);
1249 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1252 if (check_used (attr
, NULL
, where
))
1255 if (attr
->cray_pointee
)
1257 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1258 " statements", where
);
1262 attr
->cray_pointee
= 1;
1263 return gfc_check_conflict (attr
, NULL
, where
);
1268 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1270 if (check_used (attr
, name
, where
))
1273 if (attr
->is_protected
)
1275 if (!gfc_notify_std (GFC_STD_LEGACY
,
1276 "Duplicate PROTECTED attribute specified at %L",
1281 attr
->is_protected
= 1;
1282 return gfc_check_conflict (attr
, name
, where
);
1287 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1290 if (check_used (attr
, name
, where
))
1294 return gfc_check_conflict (attr
, name
, where
);
1299 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1303 if (check_used (attr
, name
, where
))
1306 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1309 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1314 if (s
== SAVE_EXPLICIT
)
1315 gfc_unset_implicit_pure (NULL
);
1317 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
1318 && (flag_automatic
|| pedantic
))
1320 if (!gfc_notify_std (GFC_STD_LEGACY
,
1321 "Duplicate SAVE attribute specified at %L",
1327 return gfc_check_conflict (attr
, name
, where
);
1332 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1335 if (check_used (attr
, name
, where
))
1340 if (!gfc_notify_std (GFC_STD_LEGACY
,
1341 "Duplicate VALUE attribute specified at %L",
1347 return gfc_check_conflict (attr
, name
, where
);
1352 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1354 /* No check_used needed as 11.2.1 of the F2003 standard allows
1355 that the local identifier made accessible by a use statement can be
1356 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1358 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1359 if (!gfc_notify_std (GFC_STD_LEGACY
,
1360 "Duplicate VOLATILE attribute specified at %L",
1364 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1365 shall not appear in a pure subprogram.
1367 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1368 construct within a pure subprogram, shall not have the SAVE or
1369 VOLATILE attribute. */
1370 if (gfc_pure (NULL
))
1372 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1373 "PURE procedure", where
);
1378 attr
->volatile_
= 1;
1379 attr
->volatile_ns
= gfc_current_ns
;
1380 return gfc_check_conflict (attr
, name
, where
);
1385 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1387 /* No check_used needed as 11.2.1 of the F2003 standard allows
1388 that the local identifier made accessible by a use statement can be
1389 given a ASYNCHRONOUS attribute. */
1391 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1392 if (!gfc_notify_std (GFC_STD_LEGACY
,
1393 "Duplicate ASYNCHRONOUS attribute specified at %L",
1397 attr
->asynchronous
= 1;
1398 attr
->asynchronous_ns
= gfc_current_ns
;
1399 return gfc_check_conflict (attr
, name
, where
);
1404 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1407 if (check_used (attr
, name
, where
))
1410 if (attr
->threadprivate
)
1412 duplicate_attr ("THREADPRIVATE", where
);
1416 attr
->threadprivate
= 1;
1417 return gfc_check_conflict (attr
, name
, where
);
1422 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1426 if (check_used (attr
, name
, where
))
1429 if (attr
->omp_declare_target
)
1432 attr
->omp_declare_target
= 1;
1433 return gfc_check_conflict (attr
, name
, where
);
1438 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1442 if (check_used (attr
, name
, where
))
1445 if (attr
->omp_declare_target_link
)
1448 attr
->omp_declare_target_link
= 1;
1449 return gfc_check_conflict (attr
, name
, where
);
1454 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1457 if (check_used (attr
, name
, where
))
1460 if (attr
->oacc_declare_create
)
1463 attr
->oacc_declare_create
= 1;
1464 return gfc_check_conflict (attr
, name
, where
);
1469 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1472 if (check_used (attr
, name
, where
))
1475 if (attr
->oacc_declare_copyin
)
1478 attr
->oacc_declare_copyin
= 1;
1479 return gfc_check_conflict (attr
, name
, where
);
1484 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1487 if (check_used (attr
, name
, where
))
1490 if (attr
->oacc_declare_deviceptr
)
1493 attr
->oacc_declare_deviceptr
= 1;
1494 return gfc_check_conflict (attr
, name
, where
);
1499 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1502 if (check_used (attr
, name
, where
))
1505 if (attr
->oacc_declare_device_resident
)
1508 attr
->oacc_declare_device_resident
= 1;
1509 return gfc_check_conflict (attr
, name
, where
);
1514 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1517 if (check_used (attr
, NULL
, where
))
1522 duplicate_attr ("TARGET", where
);
1527 return gfc_check_conflict (attr
, NULL
, where
);
1532 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1535 if (check_used (attr
, name
, where
))
1538 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1540 return gfc_check_conflict (attr
, name
, where
);
1545 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1548 if (check_used (attr
, name
, where
))
1551 /* Duplicate attribute already checked for. */
1552 attr
->in_common
= 1;
1553 return gfc_check_conflict (attr
, name
, where
);
1558 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1561 /* Duplicate attribute already checked for. */
1562 attr
->in_equivalence
= 1;
1563 if (!gfc_check_conflict (attr
, name
, where
))
1566 if (attr
->flavor
== FL_VARIABLE
)
1569 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1574 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1577 if (check_used (attr
, name
, where
))
1581 return gfc_check_conflict (attr
, name
, where
);
1586 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1589 attr
->in_namelist
= 1;
1590 return gfc_check_conflict (attr
, name
, where
);
1595 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1598 if (check_used (attr
, name
, where
))
1602 return gfc_check_conflict (attr
, name
, where
);
1607 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1610 if (check_used (attr
, NULL
, where
))
1613 if (attr
->elemental
)
1615 duplicate_attr ("ELEMENTAL", where
);
1619 attr
->elemental
= 1;
1620 return gfc_check_conflict (attr
, NULL
, where
);
1625 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1628 if (check_used (attr
, NULL
, where
))
1633 duplicate_attr ("PURE", where
);
1638 return gfc_check_conflict (attr
, NULL
, where
);
1643 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1646 if (check_used (attr
, NULL
, where
))
1649 if (attr
->recursive
)
1651 duplicate_attr ("RECURSIVE", where
);
1655 attr
->recursive
= 1;
1656 return gfc_check_conflict (attr
, NULL
, where
);
1661 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1664 if (check_used (attr
, name
, where
))
1669 duplicate_attr ("ENTRY", where
);
1674 return gfc_check_conflict (attr
, name
, where
);
1679 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1682 if (attr
->flavor
!= FL_PROCEDURE
1683 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1687 return gfc_check_conflict (attr
, name
, where
);
1692 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1695 if (attr
->flavor
!= FL_PROCEDURE
1696 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1699 attr
->subroutine
= 1;
1701 /* If we are looking at a BLOCK DATA statement and we encounter a
1702 name with a leading underscore (which must be
1703 compiler-generated), do not check. See PR 84394. */
1705 if (name
&& *name
!= '_' && gfc_current_state () != COMP_BLOCK_DATA
)
1706 return gfc_check_conflict (attr
, name
, where
);
1713 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1716 if (attr
->flavor
!= FL_PROCEDURE
1717 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1721 return gfc_check_conflict (attr
, name
, where
);
1726 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1729 if (check_used (attr
, NULL
, where
))
1732 if (attr
->flavor
!= FL_PROCEDURE
1733 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1736 if (attr
->procedure
)
1738 duplicate_attr ("PROCEDURE", where
);
1742 attr
->procedure
= 1;
1744 return gfc_check_conflict (attr
, NULL
, where
);
1749 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1753 duplicate_attr ("ABSTRACT", where
);
1759 return gfc_check_conflict (attr
, NULL
, where
);
1763 /* Flavors are special because some flavors are not what Fortran
1764 considers attributes and can be reaffirmed multiple times. */
1767 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1771 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1772 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1773 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1776 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1779 /* Copying a procedure dummy argument for a module procedure in a
1780 submodule results in the flavor being copied and would result in
1781 an error without this. */
1782 if (attr
->flavor
== f
&& f
== FL_PROCEDURE
1783 && gfc_new_block
&& gfc_new_block
->abr_modproc_decl
)
1786 if (attr
->flavor
!= FL_UNKNOWN
)
1789 where
= &gfc_current_locus
;
1792 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1793 gfc_code2string (flavors
, attr
->flavor
), name
,
1794 gfc_code2string (flavors
, f
), where
);
1796 gfc_error ("%s attribute conflicts with %s attribute at %L",
1797 gfc_code2string (flavors
, attr
->flavor
),
1798 gfc_code2string (flavors
, f
), where
);
1805 return gfc_check_conflict (attr
, name
, where
);
1810 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1811 const char *name
, locus
*where
)
1814 if (check_used (attr
, name
, where
))
1817 if (attr
->flavor
!= FL_PROCEDURE
1818 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1822 where
= &gfc_current_locus
;
1824 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
1825 && attr
->access
== ACCESS_UNKNOWN
)
1827 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1828 && !gfc_notification_std (GFC_STD_F2008
))
1829 gfc_error ("%s procedure at %L is already declared as %s "
1830 "procedure. \nF2008: A pointer function assignment "
1831 "is ambiguous if it is the first executable statement "
1832 "after the specification block. Please add any other "
1833 "kind of executable statement before it. FIXME",
1834 gfc_code2string (procedures
, t
), where
,
1835 gfc_code2string (procedures
, attr
->proc
));
1837 gfc_error ("%s procedure at %L is already declared as %s "
1838 "procedure", gfc_code2string (procedures
, t
), where
,
1839 gfc_code2string (procedures
, attr
->proc
));
1846 /* Statement functions are always scalar and functions. */
1847 if (t
== PROC_ST_FUNCTION
1848 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1849 || attr
->dimension
))
1852 return gfc_check_conflict (attr
, name
, where
);
1857 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1860 if (check_used (attr
, NULL
, where
))
1863 if (attr
->intent
== INTENT_UNKNOWN
)
1865 attr
->intent
= intent
;
1866 return gfc_check_conflict (attr
, NULL
, where
);
1870 where
= &gfc_current_locus
;
1872 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1873 gfc_intent_string (attr
->intent
),
1874 gfc_intent_string (intent
), where
);
1880 /* No checks for use-association in public and private statements. */
1883 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1884 const char *name
, locus
*where
)
1887 if (attr
->access
== ACCESS_UNKNOWN
1888 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1890 attr
->access
= access
;
1891 return gfc_check_conflict (attr
, name
, where
);
1895 where
= &gfc_current_locus
;
1896 gfc_error ("ACCESS specification at %L was already specified", where
);
1902 /* Set the is_bind_c field for the given symbol_attribute. */
1905 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1906 int is_proc_lang_bind_spec
)
1909 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1910 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1911 "variables or common blocks", where
);
1912 else if (attr
->is_bind_c
)
1913 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1915 attr
->is_bind_c
= 1;
1918 where
= &gfc_current_locus
;
1920 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1923 return gfc_check_conflict (attr
, name
, where
);
1927 /* Set the extension field for the given symbol_attribute. */
1930 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1933 where
= &gfc_current_locus
;
1935 if (attr
->extension
)
1936 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1938 attr
->extension
= 1;
1940 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1948 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1949 gfc_formal_arglist
* formal
, locus
*where
)
1951 if (check_used (&sym
->attr
, sym
->name
, where
))
1954 /* Skip the following checks in the case of a module_procedures in a
1955 submodule since they will manifestly fail. */
1956 if (sym
->attr
.module_procedure
== 1
1957 && source
== IFSRC_DECL
)
1961 where
= &gfc_current_locus
;
1963 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1964 && sym
->attr
.if_source
!= IFSRC_DECL
)
1966 gfc_error ("Symbol %qs at %L already has an explicit interface",
1971 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1973 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1974 "body", sym
->name
, where
);
1979 sym
->formal
= formal
;
1980 sym
->attr
.if_source
= source
;
1986 /* Add a type to a symbol. */
1989 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1995 where
= &gfc_current_locus
;
1998 type
= sym
->result
->ts
.type
;
2000 type
= sym
->ts
.type
;
2002 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
2003 type
= sym
->ns
->proc_name
->ts
.type
;
2005 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
2006 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
2007 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
2008 && !sym
->attr
.module_procedure
)
2010 if (sym
->attr
.use_assoc
)
2011 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2012 "use-associated at %L", sym
->name
, where
, sym
->module
,
2014 else if (sym
->attr
.function
&& sym
->attr
.result
)
2015 gfc_error ("Symbol %qs at %L already has basic type of %s",
2016 sym
->ns
->proc_name
->name
, where
, gfc_basic_typename (type
));
2018 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
2019 where
, gfc_basic_typename (type
));
2023 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
2025 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2026 sym
->name
, where
, gfc_basic_typename (ts
->type
));
2030 flavor
= sym
->attr
.flavor
;
2032 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
2033 || flavor
== FL_LABEL
2034 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
2035 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
2037 gfc_error ("Symbol %qs at %L cannot have a type",
2038 sym
->ns
->proc_name
? sym
->ns
->proc_name
->name
: sym
->name
,
2048 /* Clears all attributes. */
2051 gfc_clear_attr (symbol_attribute
*attr
)
2053 memset (attr
, 0, sizeof (symbol_attribute
));
2057 /* Check for missing attributes in the new symbol. Currently does
2058 nothing, but it's not clear that it is unnecessary yet. */
2061 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2062 locus
*where ATTRIBUTE_UNUSED
)
2069 /* Copy an attribute to a symbol attribute, bit by bit. Some
2070 attributes have a lot of side-effects but cannot be present given
2071 where we are called from, so we ignore some bits. */
2074 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2076 int is_proc_lang_bind_spec
;
2078 /* In line with the other attributes, we only add bits but do not remove
2079 them; cf. also PR 41034. */
2080 dest
->ext_attr
|= src
->ext_attr
;
2082 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2085 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2087 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2089 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2091 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2093 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2095 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2097 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2099 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2101 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2103 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2105 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2107 if (src
->threadprivate
2108 && !gfc_add_threadprivate (dest
, NULL
, where
))
2110 if (src
->omp_declare_target
2111 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2113 if (src
->omp_declare_target_link
2114 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2116 if (src
->oacc_declare_create
2117 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2119 if (src
->oacc_declare_copyin
2120 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2122 if (src
->oacc_declare_deviceptr
2123 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2125 if (src
->oacc_declare_device_resident
2126 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2128 if (src
->target
&& !gfc_add_target (dest
, where
))
2130 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2132 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2137 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2140 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2143 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2145 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2147 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2150 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2152 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2154 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2156 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2159 if (src
->flavor
!= FL_UNKNOWN
2160 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2163 if (src
->intent
!= INTENT_UNKNOWN
2164 && !gfc_add_intent (dest
, src
->intent
, where
))
2167 if (src
->access
!= ACCESS_UNKNOWN
2168 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2171 if (!gfc_missing_attr (dest
, where
))
2174 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2176 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2179 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2181 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2184 if (src
->is_c_interop
)
2185 dest
->is_c_interop
= 1;
2189 if (src
->external
&& !gfc_add_external (dest
, where
))
2191 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2193 if (src
->proc_pointer
)
2194 dest
->proc_pointer
= 1;
2203 /* A function to generate a dummy argument symbol using that from the
2204 interface declaration. Can be used for the result symbol as well if
2208 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2212 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2216 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2219 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2220 &gfc_current_locus
))
2223 if ((*dsym
)->attr
.dimension
)
2224 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2226 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2228 if ((*dsym
) != NULL
&& !result
2229 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2230 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2232 else if ((*dsym
) != NULL
&& result
2233 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2234 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2241 /************** Component name management ************/
2243 /* Component names of a derived type form their own little namespaces
2244 that are separate from all other spaces. The space is composed of
2245 a singly linked list of gfc_component structures whose head is
2246 located in the parent symbol. */
2249 /* Add a component name to a symbol. The call fails if the name is
2250 already present. On success, the component pointer is modified to
2251 point to the additional component structure. */
2254 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2255 gfc_component
**component
)
2257 gfc_component
*p
, *tail
;
2259 /* Check for existing components with the same name, but not for union
2260 components or containers. Unions and maps are anonymous so they have
2261 unique internal names which will never conflict.
2262 Don't use gfc_find_component here because it calls gfc_use_derived,
2263 but the derived type may not be fully defined yet. */
2266 for (p
= sym
->components
; p
; p
= p
->next
)
2268 if (strcmp (p
->name
, name
) == 0)
2270 gfc_error ("Component %qs at %C already declared at %L",
2278 if (sym
->attr
.extension
2279 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2280 name
, true, true, NULL
))
2282 gfc_error ("Component %qs at %C already in the parent type "
2283 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2287 /* Allocate a new component. */
2288 p
= gfc_get_component ();
2291 sym
->components
= p
;
2295 p
->name
= gfc_get_string ("%s", name
);
2296 p
->loc
= gfc_current_locus
;
2297 p
->ts
.type
= BT_UNKNOWN
;
2304 /* Recursive function to switch derived types of all symbol in a
2308 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2316 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2317 sym
->ts
.u
.derived
= to
;
2319 switch_types (st
->left
, from
, to
);
2320 switch_types (st
->right
, from
, to
);
2324 /* This subroutine is called when a derived type is used in order to
2325 make the final determination about which version to use. The
2326 standard requires that a type be defined before it is 'used', but
2327 such types can appear in IMPLICIT statements before the actual
2328 definition. 'Using' in this context means declaring a variable to
2329 be that type or using the type constructor.
2331 If a type is used and the components haven't been defined, then we
2332 have to have a derived type in a parent unit. We find the node in
2333 the other namespace and point the symtree node in this namespace to
2334 that node. Further reference to this name point to the correct
2335 node. If we can't find the node in a parent namespace, then we have
2338 This subroutine takes a pointer to a symbol node and returns a
2339 pointer to the translated node or NULL for an error. Usually there
2340 is no translation and we return the node we were passed. */
2343 gfc_use_derived (gfc_symbol
*sym
)
2353 if (sym
->attr
.unlimited_polymorphic
)
2356 if (sym
->attr
.generic
)
2357 sym
= gfc_find_dt_in_generic (sym
);
2359 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2360 return sym
; /* Already defined. */
2362 if (sym
->ns
->parent
== NULL
)
2365 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2367 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2371 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2374 /* Get rid of symbol sym, translating all references to s. */
2375 for (i
= 0; i
< GFC_LETTERS
; i
++)
2377 t
= &sym
->ns
->default_type
[i
];
2378 if (t
->u
.derived
== sym
)
2382 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2387 /* Unlink from list of modified symbols. */
2388 gfc_commit_symbol (sym
);
2390 switch_types (sym
->ns
->sym_root
, sym
, s
);
2392 /* TODO: Also have to replace sym -> s in other lists like
2393 namelists, common lists and interface lists. */
2394 gfc_free_symbol (sym
);
2399 gfc_error ("Derived type %qs at %C is being used before it is defined",
2405 /* Find the component with the given name in the union type symbol.
2406 If ref is not NULL it will be set to the chain of components through which
2407 the component can actually be accessed. This is necessary for unions because
2408 intermediate structures may be maps, nested structures, or other unions,
2409 all of which may (or must) be 'anonymous' to user code. */
2411 static gfc_component
*
2412 find_union_component (gfc_symbol
*un
, const char *name
,
2413 bool noaccess
, gfc_ref
**ref
)
2415 gfc_component
*m
, *check
;
2416 gfc_ref
*sref
, *tmp
;
2418 for (m
= un
->components
; m
; m
= m
->next
)
2420 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2424 /* Found component somewhere in m; chain the refs together. */
2428 sref
= gfc_get_ref ();
2429 sref
->type
= REF_COMPONENT
;
2430 sref
->u
.c
.component
= m
;
2431 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2436 /* Other checks (such as access) were done in the recursive calls. */
2443 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2444 the number of total candidates in CANDIDATES_LEN. */
2447 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2449 size_t &candidates_len
)
2451 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2452 vec_push (candidates
, candidates_len
, p
->name
);
2456 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2459 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2461 char **candidates
= NULL
;
2462 size_t candidates_len
= 0;
2463 lookup_component_fuzzy_find_candidates (component
, candidates
,
2465 return gfc_closest_fuzzy_match (member
, candidates
);
2469 /* Given a derived type node and a component name, try to locate the
2470 component structure. Returns the NULL pointer if the component is
2471 not found or the components are private. If noaccess is set, no access
2472 checks are done. If silent is set, an error will not be generated if
2473 the component cannot be found or accessed.
2475 If ref is not NULL, *ref is set to represent the chain of components
2476 required to get to the ultimate component.
2478 If the component is simply a direct subcomponent, or is inherited from a
2479 parent derived type in the given derived type, this is a single ref with its
2480 component set to the returned component.
2482 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2483 when the component is found through an implicit chain of nested union and
2484 map components. Unions and maps are "anonymous" substructures in FORTRAN
2485 which cannot be explicitly referenced, but the reference chain must be
2486 considered as in C for backend translation to correctly compute layouts.
2487 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2490 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2491 bool noaccess
, bool silent
, gfc_ref
**ref
)
2493 gfc_component
*p
, *check
;
2494 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2496 if (name
== NULL
|| sym
== NULL
)
2499 if (sym
->attr
.flavor
== FL_DERIVED
)
2500 sym
= gfc_use_derived (sym
);
2502 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2507 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2508 if (sym
->attr
.flavor
== FL_UNION
)
2509 return find_union_component (sym
, name
, noaccess
, ref
);
2511 if (ref
) *ref
= NULL
;
2512 for (p
= sym
->components
; p
; p
= p
->next
)
2514 /* Nest search into union's maps. */
2515 if (p
->ts
.type
== BT_UNION
)
2517 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2523 sref
= gfc_get_ref ();
2524 sref
->type
= REF_COMPONENT
;
2525 sref
->u
.c
.component
= p
;
2526 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2533 else if (strcmp (p
->name
, name
) == 0)
2539 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2541 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2542 if (p
->attr
.access
== ACCESS_PRIVATE
||
2543 (p
->attr
.access
!= ACCESS_PUBLIC
2544 && sym
->component_access
== ACCESS_PRIVATE
2545 && !is_parent_comp
))
2548 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2555 && sym
->attr
.extension
2556 && sym
->components
->ts
.type
== BT_DERIVED
)
2558 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2559 noaccess
, silent
, ref
);
2560 /* Do not overwrite the error. */
2565 if (p
== NULL
&& !silent
)
2567 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2569 gfc_error ("%qs at %C is not a member of the %qs structure"
2570 "; did you mean %qs?",
2571 name
, sym
->name
, guessed
);
2573 gfc_error ("%qs at %C is not a member of the %qs structure",
2577 /* Component was found; build the ultimate component reference. */
2578 if (p
!= NULL
&& ref
)
2580 tmp
= gfc_get_ref ();
2581 tmp
->type
= REF_COMPONENT
;
2582 tmp
->u
.c
.component
= p
;
2584 /* Link the final component ref to the end of the chain of subrefs. */
2588 for (; sref
->next
; sref
= sref
->next
)
2600 /* Given a symbol, free all of the component structures and everything
2604 free_components (gfc_component
*p
)
2612 gfc_free_array_spec (p
->as
);
2613 gfc_free_expr (p
->initializer
);
2615 gfc_free_expr (p
->kind_expr
);
2617 gfc_free_actual_arglist (p
->param_list
);
2625 /******************** Statement label management ********************/
2627 /* Comparison function for statement labels, used for managing the
2631 compare_st_labels (void *a1
, void *b1
)
2633 int a
= ((gfc_st_label
*) a1
)->value
;
2634 int b
= ((gfc_st_label
*) b1
)->value
;
2640 /* Free a single gfc_st_label structure, making sure the tree is not
2641 messed up. This function is called only when some parse error
2645 gfc_free_st_label (gfc_st_label
*label
)
2651 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2653 if (label
->format
!= NULL
)
2654 gfc_free_expr (label
->format
);
2660 /* Free a whole tree of gfc_st_label structures. */
2663 free_st_labels (gfc_st_label
*label
)
2669 free_st_labels (label
->left
);
2670 free_st_labels (label
->right
);
2672 if (label
->format
!= NULL
)
2673 gfc_free_expr (label
->format
);
2678 /* Given a label number, search for and return a pointer to the label
2679 structure, creating it if it does not exist. */
2682 gfc_get_st_label (int labelno
)
2687 if (gfc_current_state () == COMP_DERIVED
)
2688 ns
= gfc_current_block ()->f2k_derived
;
2691 /* Find the namespace of the scoping unit:
2692 If we're in a BLOCK construct, jump to the parent namespace. */
2693 ns
= gfc_current_ns
;
2694 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2698 /* First see if the label is already in this namespace. */
2702 if (lp
->value
== labelno
)
2705 if (lp
->value
< labelno
)
2711 lp
= XCNEW (gfc_st_label
);
2713 lp
->value
= labelno
;
2714 lp
->defined
= ST_LABEL_UNKNOWN
;
2715 lp
->referenced
= ST_LABEL_UNKNOWN
;
2718 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2724 /* Called when a statement with a statement label is about to be
2725 accepted. We add the label to the list of the current namespace,
2726 making sure it hasn't been defined previously and referenced
2730 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2734 labelno
= lp
->value
;
2736 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2737 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2738 &lp
->where
, label_locus
);
2741 lp
->where
= *label_locus
;
2745 case ST_LABEL_FORMAT
:
2746 if (lp
->referenced
== ST_LABEL_TARGET
2747 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2748 gfc_error ("Label %d at %C already referenced as branch target",
2751 lp
->defined
= ST_LABEL_FORMAT
;
2755 case ST_LABEL_TARGET
:
2756 case ST_LABEL_DO_TARGET
:
2757 if (lp
->referenced
== ST_LABEL_FORMAT
)
2758 gfc_error ("Label %d at %C already referenced as a format label",
2763 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2764 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2765 "DO termination statement which is not END DO"
2766 " or CONTINUE with label %d at %C", labelno
))
2771 lp
->defined
= ST_LABEL_BAD_TARGET
;
2772 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2778 /* Reference a label. Given a label and its type, see if that
2779 reference is consistent with what is known about that label,
2780 updating the unknown state. Returns false if something goes
2784 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2786 gfc_sl_type label_type
;
2793 labelno
= lp
->value
;
2795 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2796 label_type
= lp
->defined
;
2799 label_type
= lp
->referenced
;
2800 lp
->where
= gfc_current_locus
;
2803 if (label_type
== ST_LABEL_FORMAT
2804 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2806 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2811 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2812 || label_type
== ST_LABEL_BAD_TARGET
)
2813 && type
== ST_LABEL_FORMAT
)
2815 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2820 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2821 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2822 "Shared DO termination label %d at %C", labelno
))
2825 if (type
== ST_LABEL_DO_TARGET
2826 && !gfc_notify_std (GFC_STD_F2018_OBS
, "Labeled DO statement "
2827 "at %L", &gfc_current_locus
))
2830 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2831 lp
->referenced
= type
;
2839 /************** Symbol table management subroutines ****************/
2841 /* Basic details: Fortran 95 requires a potentially unlimited number
2842 of distinct namespaces when compiling a program unit. This case
2843 occurs during a compilation of internal subprograms because all of
2844 the internal subprograms must be read before we can start
2845 generating code for the host.
2847 Given the tricky nature of the Fortran grammar, we must be able to
2848 undo changes made to a symbol table if the current interpretation
2849 of a statement is found to be incorrect. Whenever a symbol is
2850 looked up, we make a copy of it and link to it. All of these
2851 symbols are kept in a vector so that we can commit or
2852 undo the changes at a later time.
2854 A symtree may point to a symbol node outside of its namespace. In
2855 this case, that symbol has been used as a host associated variable
2856 at some previous time. */
2858 /* Allocate a new namespace structure. Copies the implicit types from
2859 PARENT if PARENT_TYPES is set. */
2862 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2869 ns
= XCNEW (gfc_namespace
);
2870 ns
->sym_root
= NULL
;
2871 ns
->uop_root
= NULL
;
2872 ns
->tb_sym_root
= NULL
;
2873 ns
->finalizers
= NULL
;
2874 ns
->default_access
= ACCESS_UNKNOWN
;
2875 ns
->parent
= parent
;
2877 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2879 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2880 ns
->tb_op
[in
] = NULL
;
2883 /* Initialize default implicit types. */
2884 for (i
= 'a'; i
<= 'z'; i
++)
2886 ns
->set_flag
[i
- 'a'] = 0;
2887 ts
= &ns
->default_type
[i
- 'a'];
2889 if (parent_types
&& ns
->parent
!= NULL
)
2891 /* Copy parent settings. */
2892 *ts
= ns
->parent
->default_type
[i
- 'a'];
2896 if (flag_implicit_none
!= 0)
2902 if ('i' <= i
&& i
<= 'n')
2904 ts
->type
= BT_INTEGER
;
2905 ts
->kind
= gfc_default_integer_kind
;
2910 ts
->kind
= gfc_default_real_kind
;
2920 /* Comparison function for symtree nodes. */
2923 compare_symtree (void *_st1
, void *_st2
)
2925 gfc_symtree
*st1
, *st2
;
2927 st1
= (gfc_symtree
*) _st1
;
2928 st2
= (gfc_symtree
*) _st2
;
2930 return strcmp (st1
->name
, st2
->name
);
2934 /* Allocate a new symtree node and associate it with the new symbol. */
2937 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2941 st
= XCNEW (gfc_symtree
);
2942 st
->name
= gfc_get_string ("%s", name
);
2944 gfc_insert_bbt (root
, st
, compare_symtree
);
2949 /* Delete a symbol from the tree. Does not free the symbol itself! */
2952 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2954 gfc_symtree st
, *st0
;
2957 /* Submodules are marked as mod.submod. When freeing a submodule
2958 symbol, the symtree only has "submod", so adjust that here. */
2960 p
= strrchr(name
, '.');
2966 st0
= gfc_find_symtree (*root
, p
);
2968 st
.name
= gfc_get_string ("%s", p
);
2969 gfc_delete_bbt (root
, &st
, compare_symtree
);
2975 /* Given a root symtree node and a name, try to find the symbol within
2976 the namespace. Returns NULL if the symbol is not found. */
2979 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2985 c
= strcmp (name
, st
->name
);
2989 st
= (c
< 0) ? st
->left
: st
->right
;
2996 /* Return a symtree node with a name that is guaranteed to be unique
2997 within the namespace and corresponds to an illegal fortran name. */
3000 gfc_get_unique_symtree (gfc_namespace
*ns
)
3002 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3003 static int serial
= 0;
3005 sprintf (name
, "@%d", serial
++);
3006 return gfc_new_symtree (&ns
->sym_root
, name
);
3010 /* Given a name find a user operator node, creating it if it doesn't
3011 exist. These are much simpler than symbols because they can't be
3012 ambiguous with one another. */
3015 gfc_get_uop (const char *name
)
3019 gfc_namespace
*ns
= gfc_current_ns
;
3023 st
= gfc_find_symtree (ns
->uop_root
, name
);
3027 st
= gfc_new_symtree (&ns
->uop_root
, name
);
3029 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
3030 uop
->name
= gfc_get_string ("%s", name
);
3031 uop
->access
= ACCESS_UNKNOWN
;
3038 /* Given a name find the user operator node. Returns NULL if it does
3042 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3047 ns
= gfc_current_ns
;
3049 st
= gfc_find_symtree (ns
->uop_root
, name
);
3050 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3054 /* Update a symbol's common_block field, and take care of the associated
3055 memory management. */
3058 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3060 if (sym
->common_block
== common_block
)
3063 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3065 sym
->common_block
->refs
--;
3066 if (sym
->common_block
->refs
== 0)
3067 free (sym
->common_block
);
3069 sym
->common_block
= common_block
;
3073 /* Remove a gfc_symbol structure and everything it points to. */
3076 gfc_free_symbol (gfc_symbol
*&sym
)
3082 gfc_free_array_spec (sym
->as
);
3084 free_components (sym
->components
);
3086 gfc_free_expr (sym
->value
);
3088 gfc_free_namelist (sym
->namelist
);
3090 if (sym
->ns
!= sym
->formal_ns
)
3091 gfc_free_namespace (sym
->formal_ns
);
3093 if (!sym
->attr
.generic_copy
)
3094 gfc_free_interface (sym
->generic
);
3096 gfc_free_formal_arglist (sym
->formal
);
3098 gfc_free_namespace (sym
->f2k_derived
);
3100 set_symbol_common_block (sym
, NULL
);
3102 if (sym
->param_list
)
3103 gfc_free_actual_arglist (sym
->param_list
);
3110 /* Decrease the reference counter and free memory when we reach zero. */
3113 gfc_release_symbol (gfc_symbol
*&sym
)
3118 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
3119 && (!sym
->attr
.entry
|| !sym
->module
))
3121 /* As formal_ns contains a reference to sym, delete formal_ns just
3122 before the deletion of sym. */
3123 gfc_namespace
*ns
= sym
->formal_ns
;
3124 sym
->formal_ns
= NULL
;
3125 gfc_free_namespace (ns
);
3132 gcc_assert (sym
->refs
== 0);
3133 gfc_free_symbol (sym
);
3137 /* Allocate and initialize a new symbol node. */
3140 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3144 p
= XCNEW (gfc_symbol
);
3146 gfc_clear_ts (&p
->ts
);
3147 gfc_clear_attr (&p
->attr
);
3149 p
->declared_at
= gfc_current_locus
;
3150 p
->name
= gfc_get_string ("%s", name
);
3156 /* Generate an error if a symbol is ambiguous, and set the error flag
3160 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3163 if (st
->n
.sym
->error
)
3166 if (st
->n
.sym
->module
)
3167 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3168 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3170 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3171 "from current program unit", name
, st
->n
.sym
->name
);
3173 st
->n
.sym
->error
= 1;
3177 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3178 selector on the stack. If yes, replace it by the corresponding temporary. */
3181 select_type_insert_tmp (gfc_symtree
**st
)
3183 gfc_select_type_stack
*stack
= select_type_stack
;
3184 for (; stack
; stack
= stack
->prev
)
3185 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3188 select_type_insert_tmp (st
);
3194 /* Look for a symtree in the current procedure -- that is, go up to
3195 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3198 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3202 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3206 if (!ns
->construct_entities
)
3215 /* Search for a symtree starting in the current namespace, resorting to
3216 any parent namespaces if requested by a nonzero parent_flag.
3217 Returns true if the name is ambiguous. */
3220 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3221 gfc_symtree
**result
)
3226 ns
= gfc_current_ns
;
3230 st
= gfc_find_symtree (ns
->sym_root
, name
);
3233 select_type_insert_tmp (&st
);
3236 /* Ambiguous generic interfaces are permitted, as long
3237 as the specific interfaces are different. */
3238 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3240 ambiguous_symbol (name
, st
);
3250 /* Don't escape an interface block. */
3251 if (ns
&& !ns
->has_import_set
3252 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3259 if (gfc_current_state() == COMP_DERIVED
3260 && gfc_current_block ()->attr
.pdt_template
)
3262 gfc_symbol
*der
= gfc_current_block ();
3263 for (; der
; der
= gfc_get_derived_super_type (der
))
3265 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3267 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3282 /* Same, but returns the symbol instead. */
3285 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3286 gfc_symbol
**result
)
3291 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3296 *result
= st
->n
.sym
;
3302 /* Tells whether there is only one set of changes in the stack. */
3305 single_undo_checkpoint_p (void)
3307 if (latest_undo_chgset
== &default_undo_chgset_var
)
3309 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3314 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3319 /* Save symbol with the information necessary to back it out. */
3322 gfc_save_symbol_data (gfc_symbol
*sym
)
3327 if (!single_undo_checkpoint_p ())
3329 /* If there is more than one change set, look for the symbol in the
3330 current one. If it is found there, we can reuse it. */
3331 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3334 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3338 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3341 s
= XCNEW (gfc_symbol
);
3343 sym
->old_symbol
= s
;
3346 latest_undo_chgset
->syms
.safe_push (sym
);
3350 /* Given a name, find a symbol, or create it if it does not exist yet
3351 in the current namespace. If the symbol is found we make sure that
3354 The integer return code indicates
3356 1 The symbol name was ambiguous
3357 2 The name meant to be established was already host associated.
3359 So if the return value is nonzero, then an error was issued. */
3362 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3363 bool allow_subroutine
)
3368 /* This doesn't usually happen during resolution. */
3370 ns
= gfc_current_ns
;
3372 /* Try to find the symbol in ns. */
3373 st
= gfc_find_symtree (ns
->sym_root
, name
);
3375 if (st
== NULL
&& ns
->omp_udr_ns
)
3378 st
= gfc_find_symtree (ns
->sym_root
, name
);
3383 /* If not there, create a new symbol. */
3384 p
= gfc_new_symbol (name
, ns
);
3386 /* Add to the list of tentative symbols. */
3387 p
->old_symbol
= NULL
;
3390 latest_undo_chgset
->syms
.safe_push (p
);
3392 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3399 /* Make sure the existing symbol is OK. Ambiguous
3400 generic interfaces are permitted, as long as the
3401 specific interfaces are different. */
3402 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3404 ambiguous_symbol (name
, st
);
3409 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3410 && !(allow_subroutine
&& p
->attr
.subroutine
)
3411 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3412 && (ns
->has_import_set
|| p
->attr
.imported
)))
3414 /* Symbol is from another namespace. */
3415 gfc_error ("Symbol %qs at %C has already been host associated",
3422 /* Copy in case this symbol is changed. */
3423 gfc_save_symbol_data (p
);
3432 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3437 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3442 *result
= st
->n
.sym
;
3449 /* Subroutine that searches for a symbol, creating it if it doesn't
3450 exist, but tries to host-associate the symbol if possible. */
3453 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3458 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3462 gfc_save_symbol_data (st
->n
.sym
);
3467 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3477 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3482 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3487 i
= gfc_get_ha_sym_tree (name
, &st
);
3490 *result
= st
->n
.sym
;
3498 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3499 head->name as the common_root symtree's name might be mangled. */
3501 static gfc_symtree
*
3502 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3505 gfc_symtree
*result
;
3510 if (st
->n
.common
== head
)
3513 result
= find_common_symtree (st
->left
, head
);
3515 result
= find_common_symtree (st
->right
, head
);
3521 /* Restore previous state of symbol. Just copy simple stuff. */
3524 restore_old_symbol (gfc_symbol
*p
)
3529 old
= p
->old_symbol
;
3531 p
->ts
.type
= old
->ts
.type
;
3532 p
->ts
.kind
= old
->ts
.kind
;
3534 p
->attr
= old
->attr
;
3536 if (p
->value
!= old
->value
)
3538 gcc_checking_assert (old
->value
== NULL
);
3539 gfc_free_expr (p
->value
);
3543 if (p
->as
!= old
->as
)
3546 gfc_free_array_spec (p
->as
);
3550 p
->generic
= old
->generic
;
3551 p
->component_access
= old
->component_access
;
3553 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3555 gfc_free_namelist (p
->namelist
);
3560 if (p
->namelist_tail
!= old
->namelist_tail
)
3562 gfc_free_namelist (old
->namelist_tail
->next
);
3563 old
->namelist_tail
->next
= NULL
;
3567 p
->namelist_tail
= old
->namelist_tail
;
3569 if (p
->formal
!= old
->formal
)
3571 gfc_free_formal_arglist (p
->formal
);
3572 p
->formal
= old
->formal
;
3575 set_symbol_common_block (p
, old
->common_block
);
3576 p
->common_head
= old
->common_head
;
3578 p
->old_symbol
= old
->old_symbol
;
3583 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3584 the structure itself. */
3587 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3594 /* Given a change set pointer, free its target's contents and update it with
3595 the address of the previous change set. Note that only the contents are
3596 freed, not the target itself (the contents' container). It is not a problem
3597 as the latter will be a local variable usually. */
3600 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3602 free_undo_change_set_data (*cs
);
3607 static void free_old_symbol (gfc_symbol
*sym
);
3610 /* Merges the current change set into the previous one. The changes themselves
3611 are left untouched; only one checkpoint is forgotten. */
3614 gfc_drop_last_undo_checkpoint (void)
3619 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3621 /* No need to loop in this case. */
3622 if (s
->old_symbol
== NULL
)
3625 /* Remove the duplicate symbols. */
3626 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3629 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3631 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3632 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3633 shall contain from now on the backup symbol for S as it was
3634 at the checkpoint before. */
3635 if (s
->old_symbol
->gfc_new
)
3637 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3638 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3639 free_old_symbol (s
);
3642 restore_old_symbol (s
->old_symbol
);
3647 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3648 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3650 pop_undo_change_set (latest_undo_chgset
);
3654 /* Undoes all the changes made to symbols since the previous checkpoint.
3655 This subroutine is made simpler due to the fact that attributes are
3656 never removed once added. */
3659 gfc_restore_last_undo_checkpoint (void)
3664 FOR_EACH_VEC_ELT_REVERSE (latest_undo_chgset
->syms
, i
, p
)
3666 /* Symbol in a common block was new. Or was old and just put in common */
3668 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3670 /* If the symbol was added to any common block, it
3671 needs to be removed to stop the resolver looking
3672 for a (possibly) dead symbol. */
3673 if (p
->common_block
->head
== p
&& !p
->common_next
)
3675 gfc_symtree st
, *st0
;
3676 st0
= find_common_symtree (p
->ns
->common_root
,
3680 st
.name
= st0
->name
;
3681 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3686 if (p
->common_block
->head
== p
)
3687 p
->common_block
->head
= p
->common_next
;
3690 gfc_symbol
*cparent
, *csym
;
3692 cparent
= p
->common_block
->head
;
3693 csym
= cparent
->common_next
;
3698 csym
= csym
->common_next
;
3701 gcc_assert(cparent
->common_next
== p
);
3702 cparent
->common_next
= csym
->common_next
;
3704 p
->common_next
= NULL
;
3708 /* The derived type is saved in the symtree with the first
3709 letter capitalized; the all lower-case version to the
3710 derived type contains its associated generic function. */
3711 if (gfc_fl_struct (p
->attr
.flavor
))
3712 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3714 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3716 gfc_release_symbol (p
);
3719 restore_old_symbol (p
);
3722 latest_undo_chgset
->syms
.truncate (0);
3723 latest_undo_chgset
->tbps
.truncate (0);
3725 if (!single_undo_checkpoint_p ())
3726 pop_undo_change_set (latest_undo_chgset
);
3730 /* Makes sure that there is only one set of changes; in other words we haven't
3731 forgotten to pair a call to gfc_new_checkpoint with a call to either
3732 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3735 enforce_single_undo_checkpoint (void)
3737 gcc_checking_assert (single_undo_checkpoint_p ());
3741 /* Undoes all the changes made to symbols in the current statement. */
3744 gfc_undo_symbols (void)
3746 enforce_single_undo_checkpoint ();
3747 gfc_restore_last_undo_checkpoint ();
3751 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3752 components of old_symbol that might need deallocation are the "allocatables"
3753 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3754 namelist_tail. In case these differ between old_symbol and sym, it's just
3755 because sym->namelist has gotten a few more items. */
3758 free_old_symbol (gfc_symbol
*sym
)
3761 if (sym
->old_symbol
== NULL
)
3764 if (sym
->old_symbol
->as
!= NULL
3765 && sym
->old_symbol
->as
!= sym
->as
3766 && !(sym
->ts
.type
== BT_CLASS
3767 && sym
->ts
.u
.derived
->attr
.is_class
3768 && sym
->old_symbol
->as
== CLASS_DATA (sym
)->as
))
3769 gfc_free_array_spec (sym
->old_symbol
->as
);
3771 if (sym
->old_symbol
->value
!= sym
->value
)
3772 gfc_free_expr (sym
->old_symbol
->value
);
3774 if (sym
->old_symbol
->formal
!= sym
->formal
)
3775 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3777 free (sym
->old_symbol
);
3778 sym
->old_symbol
= NULL
;
3782 /* Makes the changes made in the current statement permanent-- gets
3783 rid of undo information. */
3786 gfc_commit_symbols (void)
3789 gfc_typebound_proc
*tbp
;
3792 enforce_single_undo_checkpoint ();
3794 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3798 free_old_symbol (p
);
3800 latest_undo_chgset
->syms
.truncate (0);
3802 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3804 latest_undo_chgset
->tbps
.truncate (0);
3808 /* Makes the changes made in one symbol permanent -- gets rid of undo
3812 gfc_commit_symbol (gfc_symbol
*sym
)
3817 enforce_single_undo_checkpoint ();
3819 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3822 latest_undo_chgset
->syms
.unordered_remove (i
);
3829 free_old_symbol (sym
);
3833 /* Recursively free trees containing type-bound procedures. */
3836 free_tb_tree (gfc_symtree
*t
)
3841 free_tb_tree (t
->left
);
3842 free_tb_tree (t
->right
);
3844 /* TODO: Free type-bound procedure u.generic */
3851 /* Recursive function that deletes an entire tree and all the common
3852 head structures it points to. */
3855 free_common_tree (gfc_symtree
* common_tree
)
3857 if (common_tree
== NULL
)
3860 free_common_tree (common_tree
->left
);
3861 free_common_tree (common_tree
->right
);
3867 /* Recursive function that deletes an entire tree and all the common
3868 head structures it points to. */
3871 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3873 if (omp_udr_tree
== NULL
)
3876 free_omp_udr_tree (omp_udr_tree
->left
);
3877 free_omp_udr_tree (omp_udr_tree
->right
);
3879 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3880 free (omp_udr_tree
);
3884 /* Recursive function that deletes an entire tree and all the user
3885 operator nodes that it contains. */
3888 free_uop_tree (gfc_symtree
*uop_tree
)
3890 if (uop_tree
== NULL
)
3893 free_uop_tree (uop_tree
->left
);
3894 free_uop_tree (uop_tree
->right
);
3896 gfc_free_interface (uop_tree
->n
.uop
->op
);
3897 free (uop_tree
->n
.uop
);
3902 /* Recursive function that deletes an entire tree and all the symbols
3903 that it contains. */
3906 free_sym_tree (gfc_symtree
*sym_tree
)
3908 if (sym_tree
== NULL
)
3911 free_sym_tree (sym_tree
->left
);
3912 free_sym_tree (sym_tree
->right
);
3914 gfc_release_symbol (sym_tree
->n
.sym
);
3919 /* Free the gfc_equiv_info's. */
3922 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3926 gfc_free_equiv_infos (s
->next
);
3931 /* Free the gfc_equiv_lists. */
3934 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3938 gfc_free_equiv_lists (l
->next
);
3939 gfc_free_equiv_infos (l
->equiv
);
3944 /* Free a finalizer procedure list. */
3947 gfc_free_finalizer (gfc_finalizer
* el
)
3951 gfc_release_symbol (el
->proc_sym
);
3957 gfc_free_finalizer_list (gfc_finalizer
* list
)
3961 gfc_finalizer
* current
= list
;
3963 gfc_free_finalizer (current
);
3968 /* Create a new gfc_charlen structure and add it to a namespace.
3969 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3972 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3976 cl
= gfc_get_charlen ();
3981 cl
->length
= gfc_copy_expr (old_cl
->length
);
3982 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3983 cl
->backend_decl
= old_cl
->backend_decl
;
3984 cl
->passed_length
= old_cl
->passed_length
;
3985 cl
->resolved
= old_cl
->resolved
;
3988 /* Put into namespace. */
3989 cl
->next
= ns
->cl_list
;
3996 /* Free the charlen list from cl to end (end is not freed).
3997 Free the whole list if end is NULL. */
4000 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
4004 for (; cl
!= end
; cl
= cl2
)
4009 gfc_free_expr (cl
->length
);
4015 /* Free entry list structs. */
4018 free_entry_list (gfc_entry_list
*el
)
4020 gfc_entry_list
*next
;
4027 free_entry_list (next
);
4031 /* Free a namespace structure and everything below it. Interface
4032 lists associated with intrinsic operators are not freed. These are
4033 taken care of when a specific name is freed. */
4036 gfc_free_namespace (gfc_namespace
*&ns
)
4038 gfc_namespace
*p
, *q
;
4040 gfc_was_finalized
*f
;
4049 gcc_assert (ns
->refs
== 0);
4051 gfc_free_statements (ns
->code
);
4053 free_sym_tree (ns
->sym_root
);
4054 free_uop_tree (ns
->uop_root
);
4055 free_common_tree (ns
->common_root
);
4056 free_omp_udr_tree (ns
->omp_udr_root
);
4057 free_tb_tree (ns
->tb_sym_root
);
4058 free_tb_tree (ns
->tb_uop_root
);
4059 gfc_free_finalizer_list (ns
->finalizers
);
4060 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4061 gfc_free_omp_declare_variant_list (ns
->omp_declare_variant
);
4062 gfc_free_charlen (ns
->cl_list
, NULL
);
4063 free_st_labels (ns
->st_labels
);
4065 free_entry_list (ns
->entries
);
4066 gfc_free_equiv (ns
->equiv
);
4067 gfc_free_equiv_lists (ns
->equiv_lists
);
4068 gfc_free_use_stmts (ns
->use_stmts
);
4070 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4071 gfc_free_interface (ns
->op
[i
]);
4073 gfc_free_data (ns
->data
);
4075 /* Free all the expr + component combinations that have been
4077 f
= ns
->was_finalized
;
4080 gfc_was_finalized
* current
= f
;
4084 if (ns
->omp_assumes
)
4086 free (ns
->omp_assumes
->absent
);
4087 free (ns
->omp_assumes
->contains
);
4088 gfc_free_expr_list (ns
->omp_assumes
->holds
);
4089 free (ns
->omp_assumes
);
4095 /* Recursively free any contained namespaces. */
4100 gfc_free_namespace (q
);
4106 gfc_symbol_init_2 (void)
4109 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4114 gfc_symbol_done_2 (void)
4116 if (gfc_current_ns
!= NULL
)
4118 /* free everything from the root. */
4119 while (gfc_current_ns
->parent
!= NULL
)
4120 gfc_current_ns
= gfc_current_ns
->parent
;
4121 gfc_free_namespace (gfc_current_ns
);
4122 gfc_current_ns
= NULL
;
4124 gfc_derived_types
= NULL
;
4126 enforce_single_undo_checkpoint ();
4127 free_undo_change_set_data (*latest_undo_chgset
);
4131 /* Count how many nodes a symtree has. */
4134 count_st_nodes (const gfc_symtree
*st
)
4140 nodes
= count_st_nodes (st
->left
);
4142 nodes
+= count_st_nodes (st
->right
);
4148 /* Convert symtree tree into symtree vector. */
4151 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4156 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4157 st_vec
[node_cntr
++] = st
;
4158 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4164 /* Traverse namespace. As the functions might modify the symtree, we store the
4165 symtree as a vector and operate on this vector. Note: We assume that
4166 sym_func or st_func never deletes nodes from the symtree - only adding is
4167 allowed. Additionally, newly added nodes are not traversed. */
4170 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4171 void (*sym_func
) (gfc_symbol
*))
4173 gfc_symtree
**st_vec
;
4174 unsigned nodes
, i
, node_cntr
;
4176 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4177 nodes
= count_st_nodes (st
);
4178 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4180 fill_st_vector (st
, st_vec
, node_cntr
);
4185 for (i
= 0; i
< nodes
; i
++)
4186 st_vec
[i
]->n
.sym
->mark
= 0;
4187 for (i
= 0; i
< nodes
; i
++)
4188 if (!st_vec
[i
]->n
.sym
->mark
)
4190 (*sym_func
) (st_vec
[i
]->n
.sym
);
4191 st_vec
[i
]->n
.sym
->mark
= 1;
4195 for (i
= 0; i
< nodes
; i
++)
4196 (*st_func
) (st_vec
[i
]);
4200 /* Recursively traverse the symtree nodes. */
4203 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4205 do_traverse_symtree (st
, st_func
, NULL
);
4209 /* Call a given function for all symbols in the namespace. We take
4210 care that each gfc_symbol node is called exactly once. */
4213 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4215 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4219 /* Return TRUE when name is the name of an intrinsic type. */
4222 gfc_is_intrinsic_typename (const char *name
)
4224 if (strcmp (name
, "integer") == 0
4225 || strcmp (name
, "real") == 0
4226 || strcmp (name
, "character") == 0
4227 || strcmp (name
, "logical") == 0
4228 || strcmp (name
, "complex") == 0
4229 || strcmp (name
, "doubleprecision") == 0
4230 || strcmp (name
, "doublecomplex") == 0)
4237 /* Return TRUE if the symbol is an automatic variable. */
4240 gfc_is_var_automatic (gfc_symbol
*sym
)
4242 /* Pointer and allocatable variables are never automatic. */
4243 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4245 /* Check for arrays with non-constant size. */
4246 if (sym
->attr
.dimension
&& sym
->as
4247 && !gfc_is_compile_time_shape (sym
->as
))
4249 /* Check for non-constant length character variables. */
4250 if (sym
->ts
.type
== BT_CHARACTER
4252 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4254 /* Variables with explicit AUTOMATIC attribute. */
4255 if (sym
->attr
.automatic
)
4261 /* Given a symbol, mark it as SAVEd if it is allowed. */
4264 save_symbol (gfc_symbol
*sym
)
4267 if (sym
->attr
.use_assoc
)
4270 if (sym
->attr
.in_common
4271 || sym
->attr
.in_equivalence
4274 || sym
->attr
.flavor
!= FL_VARIABLE
)
4276 /* Automatic objects are not saved. */
4277 if (gfc_is_var_automatic (sym
))
4279 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4283 /* Mark those symbols which can be SAVEd as such. */
4286 gfc_save_all (gfc_namespace
*ns
)
4288 gfc_traverse_ns (ns
, save_symbol
);
4292 /* Make sure that no changes to symbols are pending. */
4295 gfc_enforce_clean_symbol_state(void)
4297 enforce_single_undo_checkpoint ();
4298 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4302 /************** Global symbol handling ************/
4305 /* Search a tree for the global symbol. */
4308 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4317 c
= strcmp (name
, symbol
->name
);
4321 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4328 /* Case insensitive search a tree for the global symbol. */
4331 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4340 c
= strcasecmp (name
, symbol
->name
);
4344 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4351 /* Compare two global symbols. Used for managing the BB tree. */
4354 gsym_compare (void *_s1
, void *_s2
)
4356 gfc_gsymbol
*s1
, *s2
;
4358 s1
= (gfc_gsymbol
*) _s1
;
4359 s2
= (gfc_gsymbol
*) _s2
;
4360 return strcmp (s1
->name
, s2
->name
);
4364 /* Get a global symbol, creating it if it doesn't exist. */
4367 gfc_get_gsymbol (const char *name
, bool bind_c
)
4371 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4375 s
= XCNEW (gfc_gsymbol
);
4376 s
->type
= GSYM_UNKNOWN
;
4377 s
->name
= gfc_get_string ("%s", name
);
4380 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4386 gfc_traverse_gsymbol (gfc_gsymbol
*gsym
,
4387 void (*do_something
) (gfc_gsymbol
*, void *),
4391 gfc_traverse_gsymbol (gsym
->left
, do_something
, data
);
4393 (*do_something
) (gsym
, data
);
4396 gfc_traverse_gsymbol (gsym
->right
, do_something
, data
);
4400 get_iso_c_binding_dt (int sym_id
)
4402 gfc_symbol
*dt_list
= gfc_derived_types
;
4404 /* Loop through the derived types in the name list, searching for
4405 the desired symbol from iso_c_binding. Search the parent namespaces
4406 if necessary and requested to (parent_flag). */
4409 while (dt_list
->dt_next
!= gfc_derived_types
)
4411 if (dt_list
->from_intmod
!= INTMOD_NONE
4412 && dt_list
->intmod_sym_id
== sym_id
)
4415 dt_list
= dt_list
->dt_next
;
4423 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4424 with C. This is necessary for any derived type that is BIND(C) and for
4425 derived types that are parameters to functions that are BIND(C). All
4426 fields of the derived type are required to be interoperable, and are tested
4427 for such. If an error occurs, the errors are reported here, allowing for
4428 multiple errors to be handled for a single derived type. */
4431 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4433 gfc_component
*curr_comp
= NULL
;
4434 bool is_c_interop
= false;
4437 if (derived_sym
== NULL
)
4438 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4439 "unexpectedly NULL");
4441 /* If we've already looked at this derived symbol, do not look at it again
4442 so we don't repeat warnings/errors. */
4443 if (derived_sym
->ts
.is_c_interop
)
4446 /* The derived type must have the BIND attribute to be interoperable
4447 J3/04-007, Section 15.2.3. */
4448 if (derived_sym
->attr
.is_bind_c
!= 1)
4450 derived_sym
->ts
.is_c_interop
= 0;
4451 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4452 "attribute to be C interoperable", derived_sym
->name
,
4453 &(derived_sym
->declared_at
));
4457 curr_comp
= derived_sym
->components
;
4459 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4460 empty struct. Section 15.2 in Fortran 2003 states: "The following
4461 subclauses define the conditions under which a Fortran entity is
4462 interoperable. If a Fortran entity is interoperable, an equivalent
4463 entity may be defined by means of C and the Fortran entity is said
4464 to be interoperable with the C entity. There does not have to be such
4465 an interoperating C entity."
4467 if (curr_comp
== NULL
)
4469 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4470 "and may be inaccessible by the C companion processor",
4471 derived_sym
->name
, &(derived_sym
->declared_at
));
4472 derived_sym
->ts
.is_c_interop
= 1;
4473 derived_sym
->attr
.is_bind_c
= 1;
4478 /* Initialize the derived type as being C interoperable.
4479 If we find an error in the components, this will be set false. */
4480 derived_sym
->ts
.is_c_interop
= 1;
4482 /* Loop through the list of components to verify that the kind of
4483 each is a C interoperable type. */
4486 /* The components cannot be pointers (fortran sense).
4487 J3/04-007, Section 15.2.3, C1505. */
4488 if (curr_comp
->attr
.pointer
!= 0)
4490 gfc_error ("Component %qs at %L cannot have the "
4491 "POINTER attribute because it is a member "
4492 "of the BIND(C) derived type %qs at %L",
4493 curr_comp
->name
, &(curr_comp
->loc
),
4494 derived_sym
->name
, &(derived_sym
->declared_at
));
4498 if (curr_comp
->attr
.proc_pointer
!= 0)
4500 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4501 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4502 &curr_comp
->loc
, derived_sym
->name
,
4503 &derived_sym
->declared_at
);
4507 /* The components cannot be allocatable.
4508 J3/04-007, Section 15.2.3, C1505. */
4509 if (curr_comp
->attr
.allocatable
!= 0)
4511 gfc_error ("Component %qs at %L cannot have the "
4512 "ALLOCATABLE attribute because it is a member "
4513 "of the BIND(C) derived type %qs at %L",
4514 curr_comp
->name
, &(curr_comp
->loc
),
4515 derived_sym
->name
, &(derived_sym
->declared_at
));
4519 /* BIND(C) derived types must have interoperable components. */
4520 if (curr_comp
->ts
.type
== BT_DERIVED
4521 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4522 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4524 /* This should be allowed; the draft says a derived-type cannot
4525 have type parameters if it is has the BIND attribute. Type
4526 parameters seem to be for making parameterized derived types.
4527 There's no need to verify the type if it is c_ptr/c_funptr. */
4528 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4532 /* Grab the typespec for the given component and test the kind. */
4533 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4537 /* Report warning and continue since not fatal. The
4538 draft does specify a constraint that requires all fields
4539 to interoperate, but if the user says real(4), etc., it
4540 may interoperate with *something* in C, but the compiler
4541 most likely won't know exactly what. Further, it may not
4542 interoperate with the same data type(s) in C if the user
4543 recompiles with different flags (e.g., -m32 and -m64 on
4544 x86_64 and using integer(4) to claim interop with a
4546 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4547 /* If the derived type is bind(c), all fields must be
4549 gfc_warning (OPT_Wc_binding_type
,
4550 "Component %qs in derived type %qs at %L "
4551 "may not be C interoperable, even though "
4552 "derived type %qs is BIND(C)",
4553 curr_comp
->name
, derived_sym
->name
,
4554 &(curr_comp
->loc
), derived_sym
->name
);
4555 else if (warn_c_binding_type
)
4556 /* If derived type is param to bind(c) routine, or to one
4557 of the iso_c_binding procs, it must be interoperable, so
4558 all fields must interop too. */
4559 gfc_warning (OPT_Wc_binding_type
,
4560 "Component %qs in derived type %qs at %L "
4561 "may not be C interoperable",
4562 curr_comp
->name
, derived_sym
->name
,
4567 curr_comp
= curr_comp
->next
;
4568 } while (curr_comp
!= NULL
);
4570 if (derived_sym
->attr
.sequence
!= 0)
4572 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4573 "attribute because it is BIND(C)", derived_sym
->name
,
4574 &(derived_sym
->declared_at
));
4578 /* Mark the derived type as not being C interoperable if we found an
4579 error. If there were only warnings, proceed with the assumption
4580 it's interoperable. */
4582 derived_sym
->ts
.is_c_interop
= 0;
4588 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4591 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4595 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4596 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4598 tmp_sym
->attr
.is_c_interop
= 1;
4599 tmp_sym
->attr
.is_bind_c
= 1;
4600 tmp_sym
->ts
.is_c_interop
= 1;
4601 tmp_sym
->ts
.is_iso_c
= 1;
4602 tmp_sym
->ts
.type
= BT_DERIVED
;
4603 tmp_sym
->ts
.f90_type
= BT_VOID
;
4604 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4605 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4607 /* Set the c_address field of c_null_ptr and c_null_funptr to
4608 the value of NULL. */
4609 tmp_sym
->value
= gfc_get_expr ();
4610 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4611 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4612 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4613 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4614 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4615 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4616 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4617 c
->expr
->ts
.is_iso_c
= 1;
4623 /* Add a formal argument, gfc_formal_arglist, to the
4624 end of the given list of arguments. Set the reference to the
4625 provided symbol, param_sym, in the argument. */
4628 add_formal_arg (gfc_formal_arglist
**head
,
4629 gfc_formal_arglist
**tail
,
4630 gfc_formal_arglist
*formal_arg
,
4631 gfc_symbol
*param_sym
)
4633 /* Put in list, either as first arg or at the tail (curr arg). */
4635 *head
= *tail
= formal_arg
;
4638 (*tail
)->next
= formal_arg
;
4639 (*tail
) = formal_arg
;
4642 (*tail
)->sym
= param_sym
;
4643 (*tail
)->next
= NULL
;
4649 /* Add a procedure interface to the given symbol (i.e., store a
4650 reference to the list of formal arguments). */
4653 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4656 sym
->formal
= formal
;
4657 sym
->attr
.if_source
= source
;
4661 /* Copy the formal args from an existing symbol, src, into a new
4662 symbol, dest. New formal args are created, and the description of
4663 each arg is set according to the existing ones. This function is
4664 used when creating procedure declaration variables from a procedure
4665 declaration statement (see match_proc_decl()) to create the formal
4666 args based on the args of a given named interface.
4668 When an actual argument list is provided, skip the absent arguments
4669 unless copy_type is true.
4670 To be used together with gfc_se->ignore_optional. */
4673 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4674 gfc_actual_arglist
*actual
, bool copy_type
)
4676 gfc_formal_arglist
*head
= NULL
;
4677 gfc_formal_arglist
*tail
= NULL
;
4678 gfc_formal_arglist
*formal_arg
= NULL
;
4679 gfc_intrinsic_arg
*curr_arg
= NULL
;
4680 gfc_formal_arglist
*formal_prev
= NULL
;
4681 gfc_actual_arglist
*act_arg
= actual
;
4682 /* Save current namespace so we can change it for formal args. */
4683 gfc_namespace
*parent_ns
= gfc_current_ns
;
4685 /* Create a new namespace, which will be the formal ns (namespace
4686 of the formal args). */
4687 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4688 gfc_current_ns
->proc_name
= dest
;
4690 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4692 /* Skip absent arguments. */
4695 gcc_assert (act_arg
!= NULL
);
4696 if (act_arg
->expr
== NULL
)
4698 act_arg
= act_arg
->next
;
4702 formal_arg
= gfc_get_formal_arglist ();
4703 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4705 /* May need to copy more info for the symbol. */
4706 if (copy_type
&& act_arg
->expr
!= NULL
)
4708 formal_arg
->sym
->ts
= act_arg
->expr
->ts
;
4709 if (act_arg
->expr
->rank
> 0)
4711 formal_arg
->sym
->attr
.dimension
= 1;
4712 formal_arg
->sym
->as
= gfc_get_array_spec();
4713 formal_arg
->sym
->as
->rank
= -1;
4714 formal_arg
->sym
->as
->type
= AS_ASSUMED_RANK
;
4716 if (act_arg
->name
&& strcmp (act_arg
->name
, "%VAL") == 0)
4717 formal_arg
->sym
->pass_as_value
= 1;
4720 formal_arg
->sym
->ts
= curr_arg
->ts
;
4722 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4723 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4724 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4725 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4726 formal_arg
->sym
->attr
.dummy
= 1;
4728 /* Do not treat an actual deferred-length character argument wrongly
4729 as template for the formal argument. */
4730 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
4731 && !(formal_arg
->sym
->attr
.allocatable
4732 || formal_arg
->sym
->attr
.pointer
))
4733 formal_arg
->sym
->ts
.deferred
= false;
4735 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4736 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4738 /* If this isn't the first arg, set up the next ptr. For the
4739 last arg built, the formal_arg->next will never get set to
4740 anything other than NULL. */
4741 if (formal_prev
!= NULL
)
4742 formal_prev
->next
= formal_arg
;
4744 formal_arg
->next
= NULL
;
4746 formal_prev
= formal_arg
;
4748 /* Add arg to list of formal args. */
4749 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4751 /* Validate changes. */
4752 gfc_commit_symbol (formal_arg
->sym
);
4754 act_arg
= act_arg
->next
;
4757 /* Add the interface to the symbol. */
4758 add_proc_interface (dest
, IFSRC_DECL
, head
);
4760 /* Store the formal namespace information. */
4761 if (dest
->formal
!= NULL
)
4762 /* The current ns should be that for the dest proc. */
4763 dest
->formal_ns
= gfc_current_ns
;
4764 /* Restore the current namespace to what it was on entry. */
4765 gfc_current_ns
= parent_ns
;
4770 std_for_isocbinding_symbol (int id
)
4774 #define NAMED_INTCST(a,b,c,d) \
4777 #include "iso-c-binding.def"
4780 #define NAMED_FUNCTION(a,b,c,d) \
4783 #define NAMED_SUBROUTINE(a,b,c,d) \
4786 #include "iso-c-binding.def"
4787 #undef NAMED_FUNCTION
4788 #undef NAMED_SUBROUTINE
4791 return GFC_STD_F2003
;
4795 /* Generate the given set of C interoperable kind objects, or all
4796 interoperable kinds. This function will only be given kind objects
4797 for valid iso_c_binding defined types because this is verified when
4798 the 'use' statement is parsed. If the user gives an 'only' clause,
4799 the specific kinds are looked up; if they don't exist, an error is
4800 reported. If the user does not give an 'only' clause, all
4801 iso_c_binding symbols are generated. If a list of specific kinds
4802 is given, it must have a NULL in the first empty spot to mark the
4803 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4804 point to the symtree for c_(fun)ptr. */
4807 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4808 const char *local_name
, gfc_symtree
*dt_symtree
,
4811 const char *const name
= (local_name
&& local_name
[0])
4812 ? local_name
: c_interop_kinds_table
[s
].name
;
4813 gfc_symtree
*tmp_symtree
;
4814 gfc_symbol
*tmp_sym
= NULL
;
4817 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4820 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4822 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4823 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4824 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4827 /* Already exists in this scope so don't re-add it. */
4828 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4829 && (!tmp_sym
->attr
.generic
4830 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4831 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4833 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4834 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4836 if (gfc_derived_types
)
4838 tmp_sym
->dt_next
= gfc_derived_types
->dt_next
;
4839 gfc_derived_types
->dt_next
= tmp_sym
;
4843 tmp_sym
->dt_next
= tmp_sym
;
4845 gfc_derived_types
= tmp_sym
;
4851 /* Create the sym tree in the current ns. */
4854 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4855 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4857 /* Add to the list of tentative symbols. */
4858 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4859 tmp_sym
->old_symbol
= NULL
;
4861 tmp_sym
->gfc_new
= 1;
4863 tmp_symtree
->n
.sym
= tmp_sym
;
4868 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4869 gcc_assert (tmp_symtree
);
4870 tmp_sym
= tmp_symtree
->n
.sym
;
4873 /* Say what module this symbol belongs to. */
4874 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4875 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4876 tmp_sym
->intmod_sym_id
= s
;
4877 tmp_sym
->attr
.is_iso_c
= 1;
4878 tmp_sym
->attr
.use_assoc
= 1;
4880 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4881 || s
== ISOCBINDING_NULL_PTR
);
4886 #define NAMED_INTCST(a,b,c,d) case a :
4887 #define NAMED_REALCST(a,b,c,d) case a :
4888 #define NAMED_CMPXCST(a,b,c,d) case a :
4889 #define NAMED_LOGCST(a,b,c) case a :
4890 #define NAMED_CHARKNDCST(a,b,c) case a :
4891 #include "iso-c-binding.def"
4893 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4894 c_interop_kinds_table
[s
].value
);
4896 /* Initialize an integer constant expression node. */
4897 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4898 tmp_sym
->ts
.type
= BT_INTEGER
;
4899 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4901 /* Mark this type as a C interoperable one. */
4902 tmp_sym
->ts
.is_c_interop
= 1;
4903 tmp_sym
->ts
.is_iso_c
= 1;
4904 tmp_sym
->value
->ts
.is_c_interop
= 1;
4905 tmp_sym
->value
->ts
.is_iso_c
= 1;
4906 tmp_sym
->attr
.is_c_interop
= 1;
4908 /* Tell what f90 type this c interop kind is valid. */
4909 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4914 #define NAMED_CHARCST(a,b,c) case a :
4915 #include "iso-c-binding.def"
4917 /* Initialize an integer constant expression node for the
4918 length of the character. */
4919 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4920 &gfc_current_locus
, NULL
, 1);
4921 tmp_sym
->value
->ts
.is_c_interop
= 1;
4922 tmp_sym
->value
->ts
.is_iso_c
= 1;
4923 tmp_sym
->value
->value
.character
.length
= 1;
4924 tmp_sym
->value
->value
.character
.string
[0]
4925 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4926 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4927 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4930 /* May not need this in both attr and ts, but do need in
4931 attr for writing module file. */
4932 tmp_sym
->attr
.is_c_interop
= 1;
4934 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4935 tmp_sym
->ts
.type
= BT_CHARACTER
;
4937 /* Need to set it to the C_CHAR kind. */
4938 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4940 /* Mark this type as a C interoperable one. */
4941 tmp_sym
->ts
.is_c_interop
= 1;
4942 tmp_sym
->ts
.is_iso_c
= 1;
4944 /* Tell what f90 type this c interop kind is valid. */
4945 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4949 case ISOCBINDING_PTR
:
4950 case ISOCBINDING_FUNPTR
:
4953 gfc_component
*tmp_comp
= NULL
;
4955 /* Generate real derived type. */
4960 const char *hidden_name
;
4961 gfc_interface
*intr
, *head
;
4963 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4964 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4966 gcc_assert (tmp_symtree
== NULL
);
4967 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4968 dt_sym
= tmp_symtree
->n
.sym
;
4969 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4970 ? "c_ptr" : "c_funptr");
4972 /* Generate an artificial generic function. */
4973 head
= tmp_sym
->generic
;
4974 intr
= gfc_get_interface ();
4976 intr
->where
= gfc_current_locus
;
4978 tmp_sym
->generic
= intr
;
4980 if (!tmp_sym
->attr
.generic
4981 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4984 if (!tmp_sym
->attr
.function
4985 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4989 /* Say what module this symbol belongs to. */
4990 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4991 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4992 dt_sym
->intmod_sym_id
= s
;
4993 dt_sym
->attr
.use_assoc
= 1;
4995 /* Initialize an integer constant expression node. */
4996 dt_sym
->attr
.flavor
= FL_DERIVED
;
4997 dt_sym
->ts
.is_c_interop
= 1;
4998 dt_sym
->attr
.is_c_interop
= 1;
4999 dt_sym
->attr
.private_comp
= 1;
5000 dt_sym
->component_access
= ACCESS_PRIVATE
;
5001 dt_sym
->ts
.is_iso_c
= 1;
5002 dt_sym
->ts
.type
= BT_DERIVED
;
5003 dt_sym
->ts
.f90_type
= BT_VOID
;
5005 /* A derived type must have the bind attribute to be
5006 interoperable (J3/04-007, Section 15.2.3), even though
5007 the binding label is not used. */
5008 dt_sym
->attr
.is_bind_c
= 1;
5010 dt_sym
->attr
.referenced
= 1;
5011 dt_sym
->ts
.u
.derived
= dt_sym
;
5013 /* Add the symbol created for the derived type to the current ns. */
5014 if (gfc_derived_types
)
5016 dt_sym
->dt_next
= gfc_derived_types
->dt_next
;
5017 gfc_derived_types
->dt_next
= dt_sym
;
5021 dt_sym
->dt_next
= dt_sym
;
5023 gfc_derived_types
= dt_sym
;
5025 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
5026 if (tmp_comp
== NULL
)
5029 tmp_comp
->ts
.type
= BT_INTEGER
;
5031 /* Set this because the module will need to read/write this field. */
5032 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
5034 /* The kinds for c_ptr and c_funptr are the same. */
5035 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
5036 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
5037 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
5039 /* Mark the component as C interoperable. */
5040 tmp_comp
->ts
.is_c_interop
= 1;
5045 case ISOCBINDING_NULL_PTR
:
5046 case ISOCBINDING_NULL_FUNPTR
:
5047 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
5053 gfc_commit_symbol (tmp_sym
);
5058 /* Check that a symbol is already typed. If strict is not set, an untyped
5059 symbol is acceptable for non-standard-conforming mode. */
5062 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5063 bool strict
, locus where
)
5067 if (gfc_matching_prefix
)
5070 /* Check for the type and try to give it an implicit one. */
5071 if (sym
->ts
.type
== BT_UNKNOWN
5072 && !gfc_set_default_type (sym
, 0, ns
))
5076 gfc_error ("Symbol %qs is used before it is typed at %L",
5081 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5082 " it is typed at %L", sym
->name
, &where
))
5086 /* Everything is ok. */
5091 /* Construct a typebound-procedure structure. Those are stored in a tentative
5092 list and marked `error' until symbols are committed. */
5095 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5097 gfc_typebound_proc
*result
;
5099 result
= XCNEW (gfc_typebound_proc
);
5104 latest_undo_chgset
->tbps
.safe_push (result
);
5110 /* Get the super-type of a given derived type. */
5113 gfc_get_derived_super_type (gfc_symbol
* derived
)
5115 gcc_assert (derived
);
5117 if (derived
->attr
.generic
)
5118 derived
= gfc_find_dt_in_generic (derived
);
5120 if (!derived
->attr
.extension
)
5123 gcc_assert (derived
->components
);
5124 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5125 gcc_assert (derived
->components
->ts
.u
.derived
);
5127 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5128 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5130 return derived
->components
->ts
.u
.derived
;
5134 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5137 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5139 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5140 t2
= gfc_get_derived_super_type (t2
);
5141 return gfc_compare_derived_types (t1
, t2
);
5145 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5146 If ts1 is nonpolymorphic, ts2 must be the same type.
5147 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5150 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5152 bool is_class1
= (ts1
->type
== BT_CLASS
);
5153 bool is_class2
= (ts2
->type
== BT_CLASS
);
5154 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5155 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5156 bool is_union1
= (ts1
->type
== BT_UNION
);
5157 bool is_union2
= (ts2
->type
== BT_UNION
);
5159 /* A boz-literal-constant has no type. */
5160 if (ts1
->type
== BT_BOZ
|| ts2
->type
== BT_BOZ
)
5164 && ts1
->u
.derived
->components
5165 && ((ts1
->u
.derived
->attr
.is_class
5166 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5167 .unlimited_polymorphic
)
5168 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5171 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5172 && !is_union1
&& !is_union2
)
5173 return (ts1
->type
== ts2
->type
);
5175 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5176 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5178 if (is_derived1
&& is_class2
)
5179 return gfc_compare_derived_types (ts1
->u
.derived
,
5180 ts2
->u
.derived
->attr
.is_class
?
5181 ts2
->u
.derived
->components
->ts
.u
.derived
5183 if (is_class1
&& is_derived2
)
5184 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5185 ts1
->u
.derived
->components
->ts
.u
.derived
5188 else if (is_class1
&& is_class2
)
5189 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5190 ts1
->u
.derived
->components
->ts
.u
.derived
5192 ts2
->u
.derived
->attr
.is_class
?
5193 ts2
->u
.derived
->components
->ts
.u
.derived
5200 /* Find the parent-namespace of the current function. If we're inside
5201 BLOCK constructs, it may not be the current one. */
5204 gfc_find_proc_namespace (gfc_namespace
* ns
)
5206 while (ns
->construct_entities
)
5216 /* Check if an associate-variable should be translated as an `implicit' pointer
5217 internally (if it is associated to a variable and not an array with
5221 gfc_is_associate_pointer (gfc_symbol
* sym
)
5226 if (sym
->ts
.type
== BT_CLASS
)
5229 if (sym
->ts
.type
== BT_CHARACTER
5231 && sym
->assoc
->target
5232 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5235 if (!sym
->assoc
->variable
)
5238 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5246 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5248 gfc_interface
*intr
= NULL
;
5250 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5253 if (sym
->attr
.generic
)
5254 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5255 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5257 return intr
? intr
->sym
: NULL
;
5261 /* Get the dummy arguments from a procedure symbol. If it has been declared
5262 via a PROCEDURE statement with a named interface, ts.interface will be set
5263 and the arguments need to be taken from there. */
5265 gfc_formal_arglist
*
5266 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5268 gfc_formal_arglist
*dummies
;
5273 dummies
= sym
->formal
;
5274 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5275 dummies
= sym
->ts
.interface
->formal
;