1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2024 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/>. */
22 #define INCLUDE_MEMORY
25 #include "coretypes.h"
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors
[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
41 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
42 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
43 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
44 minit ("UNION", FL_UNION
), minit ("STRUCTURE", FL_STRUCT
),
48 const mstring procedures
[] =
50 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
51 minit ("MODULE-PROC", PROC_MODULE
),
52 minit ("INTERNAL-PROC", PROC_INTERNAL
),
53 minit ("DUMMY-PROC", PROC_DUMMY
),
54 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
55 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
56 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
60 const mstring intents
[] =
62 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
63 minit ("IN", INTENT_IN
),
64 minit ("OUT", INTENT_OUT
),
65 minit ("INOUT", INTENT_INOUT
),
69 const mstring access_types
[] =
71 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
72 minit ("PUBLIC", ACCESS_PUBLIC
),
73 minit ("PRIVATE", ACCESS_PRIVATE
),
77 const mstring ifsrc_types
[] =
79 minit ("UNKNOWN", IFSRC_UNKNOWN
),
80 minit ("DECL", IFSRC_DECL
),
81 minit ("BODY", IFSRC_IFBODY
)
84 const mstring save_status
[] =
86 minit ("UNKNOWN", SAVE_NONE
),
87 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
88 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
91 /* Set the mstrings for DTIO procedure names. */
92 const mstring dtio_procs
[] =
94 minit ("_dtio_formatted_read", DTIO_RF
),
95 minit ("_dtio_formatted_write", DTIO_WF
),
96 minit ("_dtio_unformatted_read", DTIO_RUF
),
97 minit ("_dtio_unformatted_write", DTIO_WUF
),
100 /* This is to make sure the backend generates setup code in the correct
102 static int next_decl_order
= 1;
104 gfc_namespace
*gfc_current_ns
;
105 gfc_namespace
*gfc_global_ns_list
;
107 gfc_gsymbol
*gfc_gsym_root
= NULL
;
109 gfc_symbol
*gfc_derived_types
;
111 static gfc_undo_change_set default_undo_chgset_var
= { vNULL
, vNULL
, NULL
};
112 static gfc_undo_change_set
*latest_undo_chgset
= &default_undo_chgset_var
;
115 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
117 /* The following static variable indicates whether a particular element has
118 been explicitly set or not. */
120 static int new_flag
[GFC_LETTERS
];
123 /* Handle a correctly parsed IMPLICIT NONE. */
126 gfc_set_implicit_none (bool type
, bool external
, locus
*loc
)
131 gfc_current_ns
->has_implicit_none_export
= 1;
135 gfc_current_ns
->seen_implicit_none
= 1;
136 for (i
= 0; i
< GFC_LETTERS
; i
++)
138 if (gfc_current_ns
->set_flag
[i
])
140 gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
141 "IMPLICIT statement", loc
);
144 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
145 gfc_current_ns
->set_flag
[i
] = 1;
151 /* Reset the implicit range flags. */
154 gfc_clear_new_implicit (void)
158 for (i
= 0; i
< GFC_LETTERS
; i
++)
163 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
166 gfc_add_new_implicit_range (int c1
, int c2
)
173 for (i
= c1
; i
<= c2
; i
++)
177 gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
189 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
190 the new implicit types back into the existing types will work. */
193 gfc_merge_new_implicit (gfc_typespec
*ts
)
197 if (gfc_current_ns
->seen_implicit_none
)
199 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
203 for (i
= 0; i
< GFC_LETTERS
; i
++)
207 if (gfc_current_ns
->set_flag
[i
])
209 gfc_error ("Letter %qc already has an IMPLICIT type at %C",
214 gfc_current_ns
->default_type
[i
] = *ts
;
215 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
216 gfc_current_ns
->set_flag
[i
] = 1;
223 /* Given a symbol, return a pointer to the typespec for its default type. */
226 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
232 if (flag_allow_leading_underscore
&& letter
== '_')
233 gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
234 "gfortran developers, and should not be used for "
235 "implicitly typed variables");
237 if (letter
< 'a' || letter
> 'z')
238 gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name
);
243 return &ns
->default_type
[letter
- 'a'];
247 /* Recursively append candidate SYM to CANDIDATES. Store the number of
248 candidates in CANDIDATES_LEN. */
251 lookup_symbol_fuzzy_find_candidates (gfc_symtree
*sym
,
253 size_t &candidates_len
)
260 if (sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
&& sym
->n
.sym
->ts
.type
!= BT_PROCEDURE
)
261 vec_push (candidates
, candidates_len
, sym
->name
);
264 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
268 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
272 /* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
275 lookup_symbol_fuzzy (const char *sym_name
, gfc_symbol
*symbol
)
277 char **candidates
= NULL
;
278 size_t candidates_len
= 0;
279 lookup_symbol_fuzzy_find_candidates (symbol
->ns
->sym_root
, candidates
,
281 return gfc_closest_fuzzy_match (sym_name
, candidates
);
285 /* Given a pointer to a symbol, set its type according to the first
286 letter of its name. Fails if the letter in question has no default
290 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
295 /* Check to see if a function selector of unknown type can be resolved. */
297 && (e
= sym
->assoc
->target
)
298 && e
->expr_type
== EXPR_FUNCTION
)
300 if (e
->ts
.type
== BT_UNKNOWN
)
301 gfc_resolve_expr (e
);
303 if (sym
->ts
.type
!= BT_UNKNOWN
)
307 if (sym
->ts
.type
!= BT_UNKNOWN
)
308 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
310 ts
= gfc_get_default_type (sym
->name
, ns
);
312 if (ts
->type
== BT_UNKNOWN
)
314 if (error_flag
&& !sym
->attr
.untyped
&& !gfc_query_suppress_errors ())
316 const char *guessed
= lookup_symbol_fuzzy (sym
->name
, sym
);
318 gfc_error ("Symbol %qs at %L has no IMPLICIT type"
319 "; did you mean %qs?",
320 sym
->name
, &sym
->declared_at
, guessed
);
322 gfc_error ("Symbol %qs at %L has no IMPLICIT type",
323 sym
->name
, &sym
->declared_at
);
324 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
331 sym
->attr
.implicit_type
= 1;
333 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
334 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
335 else if (ts
->type
== BT_CLASS
336 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
339 if (sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
341 /* BIND(C) variables should not be implicitly declared. */
342 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared BIND(C) "
343 "variable %qs at %L may not be C interoperable",
344 sym
->name
, &sym
->declared_at
);
345 sym
->ts
.f90_type
= sym
->ts
.type
;
348 if (sym
->attr
.dummy
!= 0)
350 if (sym
->ns
->proc_name
!= NULL
351 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
352 || sym
->ns
->proc_name
->attr
.function
!= 0)
353 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0
354 && warn_c_binding_type
)
356 /* Dummy args to a BIND(C) routine may not be interoperable if
357 they are implicitly typed. */
358 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared variable "
359 "%qs at %L may not be C interoperable but it is a "
360 "dummy argument to the BIND(C) procedure %qs at %L",
361 sym
->name
, &(sym
->declared_at
),
362 sym
->ns
->proc_name
->name
,
363 &(sym
->ns
->proc_name
->declared_at
));
364 sym
->ts
.f90_type
= sym
->ts
.type
;
372 /* This function is called from parse.cc(parse_progunit) to check the
373 type of the function is not implicitly typed in the host namespace
374 and to implicitly type the function result, if necessary. */
377 gfc_check_function_type (gfc_namespace
*ns
)
379 gfc_symbol
*proc
= ns
->proc_name
;
381 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
384 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
386 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
))
388 if (proc
->result
!= proc
)
390 proc
->ts
= proc
->result
->ts
;
391 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
392 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
393 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
394 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
397 else if (!proc
->result
->attr
.proc_pointer
)
399 gfc_error ("Function result %qs at %L has no IMPLICIT type",
400 proc
->result
->name
, &proc
->result
->declared_at
);
401 proc
->result
->attr
.untyped
= 1;
407 /******************** Symbol attribute stuff *********************/
409 /* Older standards produced conflicts for some attributes that are allowed
410 in newer standards. Check for the conflict and issue an error depending
411 on the standard in play. */
414 conflict_std (int standard
, const char *a1
, const char *a2
, const char *name
,
419 return gfc_notify_std (standard
, "%s attribute conflicts "
420 "with %s attribute at %L", a1
, a2
,
425 return gfc_notify_std (standard
, "%s attribute conflicts "
426 "with %s attribute in %qs at %L",
427 a1
, a2
, name
, where
);
431 /* This is a generic conflict-checker. We do this to avoid having a
432 single conflict in two places. */
434 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
435 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
436 #define conf_std(a, b, std) if (attr->a && attr->b \
437 && !conflict_std (std, a, b, name, where)) \
441 gfc_check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
443 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
444 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
445 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
446 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
447 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
448 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
449 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
450 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
451 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
452 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
453 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
454 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
455 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
456 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
457 *proc_pointer
= "PROCEDURE POINTER", *abstract
= "ABSTRACT",
458 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
459 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC", *automatic
= "AUTOMATIC",
460 *pdt_len
= "LEN", *pdt_kind
= "KIND";
461 static const char *threadprivate
= "THREADPRIVATE";
462 static const char *omp_declare_target
= "OMP DECLARE TARGET";
463 static const char *omp_declare_target_link
= "OMP DECLARE TARGET LINK";
464 static const char *oacc_declare_copyin
= "OACC DECLARE COPYIN";
465 static const char *oacc_declare_create
= "OACC DECLARE CREATE";
466 static const char *oacc_declare_deviceptr
= "OACC DECLARE DEVICEPTR";
467 static const char *oacc_declare_device_resident
=
468 "OACC DECLARE DEVICE_RESIDENT";
472 if (attr
->artificial
)
476 where
= &gfc_current_locus
;
478 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
479 conf_std (pointer
, intent
, GFC_STD_F2003
);
481 conf_std (in_namelist
, allocatable
, GFC_STD_F2003
);
482 conf_std (in_namelist
, pointer
, GFC_STD_F2003
);
484 /* Check for attributes not allowed in a BLOCK DATA. */
485 if (gfc_current_state () == COMP_BLOCK_DATA
)
489 if (attr
->in_namelist
)
491 if (attr
->allocatable
)
497 if (attr
->access
== ACCESS_PRIVATE
)
499 if (attr
->access
== ACCESS_PUBLIC
)
501 if (attr
->intent
!= INTENT_UNKNOWN
)
507 ("%s attribute not allowed in BLOCK DATA program unit at %L",
513 if (attr
->save
== SAVE_EXPLICIT
)
516 conf (in_common
, save
);
518 conf (automatic
, save
);
520 switch (attr
->flavor
)
528 a1
= gfc_code2string (flavors
, attr
->flavor
);
532 gfc_error ("Namelist group name at %L cannot have the "
533 "SAVE attribute", where
);
536 /* Conflicts between SAVE and PROCEDURE will be checked at
537 resolution stage, see "resolve_fl_procedure". */
544 /* The copying of procedure dummy arguments for module procedures in
545 a submodule occur whilst the current state is COMP_CONTAINS. It
546 is necessary, therefore, to let this through. */
547 if (name
&& attr
->dummy
548 && (attr
->function
|| attr
->subroutine
)
549 && gfc_current_state () == COMP_CONTAINS
550 && !(gfc_new_block
&& gfc_new_block
->abr_modproc_decl
))
551 gfc_error_now ("internal procedure %qs at %L conflicts with "
552 "DUMMY argument", name
, where
);
555 conf (dummy
, intrinsic
);
556 conf (dummy
, threadprivate
);
557 conf (dummy
, omp_declare_target
);
558 conf (dummy
, omp_declare_target_link
);
559 conf (pointer
, target
);
560 conf (pointer
, intrinsic
);
561 conf (pointer
, elemental
);
562 conf (pointer
, codimension
);
563 conf (allocatable
, elemental
);
565 conf (in_common
, automatic
);
566 conf (result
, automatic
);
567 conf (use_assoc
, automatic
);
568 conf (dummy
, automatic
);
570 conf (target
, external
);
571 conf (target
, intrinsic
);
573 if (!attr
->if_source
)
574 conf (external
, dimension
); /* See Fortran 95's R504. */
576 conf (external
, intrinsic
);
577 conf (entry
, intrinsic
);
578 conf (abstract
, intrinsic
);
580 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
581 conf (external
, subroutine
);
583 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
584 "Procedure pointer at %C"))
587 conf (allocatable
, pointer
);
588 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
589 conf_std (allocatable
, function
, GFC_STD_F2003
);
590 conf_std (allocatable
, result
, GFC_STD_F2003
);
591 conf_std (elemental
, recursive
, GFC_STD_F2018
);
593 conf (in_common
, dummy
);
594 conf (in_common
, allocatable
);
595 conf (in_common
, codimension
);
596 conf (in_common
, result
);
598 conf (in_equivalence
, use_assoc
);
599 conf (in_equivalence
, codimension
);
600 conf (in_equivalence
, dummy
);
601 conf (in_equivalence
, target
);
602 conf (in_equivalence
, pointer
);
603 conf (in_equivalence
, function
);
604 conf (in_equivalence
, result
);
605 conf (in_equivalence
, entry
);
606 conf (in_equivalence
, allocatable
);
607 conf (in_equivalence
, threadprivate
);
608 conf (in_equivalence
, omp_declare_target
);
609 conf (in_equivalence
, omp_declare_target_link
);
610 conf (in_equivalence
, oacc_declare_create
);
611 conf (in_equivalence
, oacc_declare_copyin
);
612 conf (in_equivalence
, oacc_declare_deviceptr
);
613 conf (in_equivalence
, oacc_declare_device_resident
);
614 conf (in_equivalence
, is_bind_c
);
616 conf (dummy
, result
);
617 conf (entry
, result
);
618 conf (generic
, result
);
619 conf (generic
, omp_declare_target
);
620 conf (generic
, omp_declare_target_link
);
622 conf (function
, subroutine
);
624 if (!function
&& !subroutine
)
625 conf (is_bind_c
, dummy
);
627 conf (is_bind_c
, cray_pointer
);
628 conf (is_bind_c
, cray_pointee
);
629 conf (is_bind_c
, codimension
);
630 conf (is_bind_c
, allocatable
);
631 conf (is_bind_c
, elemental
);
633 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
634 Parameter conflict caught below. Also, value cannot be specified
635 for a dummy procedure. */
637 /* Cray pointer/pointee conflicts. */
638 conf (cray_pointer
, cray_pointee
);
639 conf (cray_pointer
, dimension
);
640 conf (cray_pointer
, codimension
);
641 conf (cray_pointer
, contiguous
);
642 conf (cray_pointer
, pointer
);
643 conf (cray_pointer
, target
);
644 conf (cray_pointer
, allocatable
);
645 conf (cray_pointer
, external
);
646 conf (cray_pointer
, intrinsic
);
647 conf (cray_pointer
, in_namelist
);
648 conf (cray_pointer
, function
);
649 conf (cray_pointer
, subroutine
);
650 conf (cray_pointer
, entry
);
652 conf (cray_pointee
, allocatable
);
653 conf (cray_pointee
, contiguous
);
654 conf (cray_pointee
, codimension
);
655 conf (cray_pointee
, intent
);
656 conf (cray_pointee
, optional
);
657 conf (cray_pointee
, dummy
);
658 conf (cray_pointee
, target
);
659 conf (cray_pointee
, intrinsic
);
660 conf (cray_pointee
, pointer
);
661 conf (cray_pointee
, entry
);
662 conf (cray_pointee
, in_common
);
663 conf (cray_pointee
, in_equivalence
);
664 conf (cray_pointee
, threadprivate
);
665 conf (cray_pointee
, omp_declare_target
);
666 conf (cray_pointee
, omp_declare_target_link
);
667 conf (cray_pointee
, oacc_declare_create
);
668 conf (cray_pointee
, oacc_declare_copyin
);
669 conf (cray_pointee
, oacc_declare_deviceptr
);
670 conf (cray_pointee
, oacc_declare_device_resident
);
673 conf (data
, function
);
675 conf (data
, allocatable
);
677 conf (value
, pointer
)
678 conf (value
, allocatable
)
679 conf (value
, subroutine
)
680 conf (value
, function
)
681 conf (value
, volatile_
)
682 conf (value
, dimension
)
683 conf (value
, codimension
)
684 conf (value
, external
)
686 conf (codimension
, result
)
689 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
692 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
696 conf (is_protected
, intrinsic
)
697 conf (is_protected
, in_common
)
699 conf (asynchronous
, intrinsic
)
700 conf (asynchronous
, external
)
702 conf (volatile_
, intrinsic
)
703 conf (volatile_
, external
)
705 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
712 conf (procedure
, allocatable
)
713 conf (procedure
, dimension
)
714 conf (procedure
, codimension
)
715 conf (procedure
, intrinsic
)
716 conf (procedure
, target
)
717 conf (procedure
, value
)
718 conf (procedure
, volatile_
)
719 conf (procedure
, asynchronous
)
720 conf (procedure
, entry
)
722 conf (proc_pointer
, abstract
)
723 conf (proc_pointer
, omp_declare_target
)
724 conf (proc_pointer
, omp_declare_target_link
)
726 conf (entry
, omp_declare_target
)
727 conf (entry
, omp_declare_target_link
)
728 conf (entry
, oacc_declare_create
)
729 conf (entry
, oacc_declare_copyin
)
730 conf (entry
, oacc_declare_deviceptr
)
731 conf (entry
, oacc_declare_device_resident
)
733 conf (pdt_kind
, allocatable
)
734 conf (pdt_kind
, pointer
)
735 conf (pdt_kind
, dimension
)
736 conf (pdt_kind
, codimension
)
738 conf (pdt_len
, allocatable
)
739 conf (pdt_len
, pointer
)
740 conf (pdt_len
, dimension
)
741 conf (pdt_len
, codimension
)
742 conf (pdt_len
, pdt_kind
)
744 if (attr
->access
== ACCESS_PRIVATE
)
751 a1
= gfc_code2string (flavors
, attr
->flavor
);
753 if (attr
->in_namelist
754 && attr
->flavor
!= FL_VARIABLE
755 && attr
->flavor
!= FL_PROCEDURE
756 && attr
->flavor
!= FL_UNKNOWN
)
762 switch (attr
->flavor
)
772 conf2 (asynchronous
);
775 conf2 (is_protected
);
785 conf2 (threadprivate
);
786 conf2 (omp_declare_target
);
787 conf2 (omp_declare_target_link
);
788 conf2 (oacc_declare_create
);
789 conf2 (oacc_declare_copyin
);
790 conf2 (oacc_declare_deviceptr
);
791 conf2 (oacc_declare_device_resident
);
793 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
795 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
796 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
803 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
817 /* Conflicts with INTENT, SAVE and RESULT will be checked
818 at resolution stage, see "resolve_fl_procedure". */
820 if (attr
->subroutine
)
826 conf2 (asynchronous
);
831 if (!attr
->proc_pointer
)
832 conf2 (threadprivate
);
835 /* Procedure pointers in COMMON blocks are allowed in F03,
836 * but forbidden per F08:C5100. */
837 if (!attr
->proc_pointer
|| (gfc_option
.allow_std
& GFC_STD_F2008
))
840 conf2 (omp_declare_target_link
);
844 case PROC_ST_FUNCTION
:
855 conf2 (threadprivate
);
875 conf2 (threadprivate
);
877 conf2 (omp_declare_target
);
878 conf2 (omp_declare_target_link
);
879 conf2 (oacc_declare_create
);
880 conf2 (oacc_declare_copyin
);
881 conf2 (oacc_declare_deviceptr
);
882 conf2 (oacc_declare_device_resident
);
884 if (attr
->intent
!= INTENT_UNKNOWN
)
901 conf2 (is_protected
);
907 conf2 (asynchronous
);
908 conf2 (threadprivate
);
924 gfc_error ("%s attribute conflicts with %s attribute at %L",
927 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
928 a1
, a2
, name
, where
);
938 /* Mark a symbol as referenced. */
941 gfc_set_sym_referenced (gfc_symbol
*sym
)
943 if (sym
->attr
.referenced
)
946 sym
->attr
.referenced
= 1;
948 /* Remember the declaration order. */
949 sym
->decl_order
= next_decl_order
++;
953 /* Common subroutine called by attribute changing subroutines in order
954 to prevent them from changing a symbol that has been
955 use-associated. Returns zero if it is OK to change the symbol,
959 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
962 if (attr
->use_assoc
== 0)
966 where
= &gfc_current_locus
;
969 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
972 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
979 /* Generate an error because of a duplicate attribute. */
982 duplicate_attr (const char *attr
, locus
*where
)
986 where
= &gfc_current_locus
;
988 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
993 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
994 locus
*where ATTRIBUTE_UNUSED
)
996 attr
->ext_attr
|= 1 << ext_attr
;
1001 /* Called from decl.cc (attr_decl1) to check attributes, when declared
1005 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
1007 if (check_used (attr
, NULL
, where
))
1010 return gfc_check_conflict (attr
, NULL
, where
);
1015 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
1018 if (check_used (attr
, NULL
, where
))
1021 if (attr
->allocatable
&& ! gfc_submodule_procedure(attr
))
1023 duplicate_attr ("ALLOCATABLE", where
);
1027 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1028 && !gfc_find_state (COMP_INTERFACE
))
1030 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1035 attr
->allocatable
= 1;
1036 return gfc_check_conflict (attr
, NULL
, where
);
1041 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1043 if (check_used (attr
, name
, where
))
1046 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
1047 "Duplicate AUTOMATIC attribute specified at %L", where
))
1050 attr
->automatic
= 1;
1051 return gfc_check_conflict (attr
, name
, where
);
1056 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1059 if (check_used (attr
, name
, where
))
1062 if (attr
->codimension
)
1064 duplicate_attr ("CODIMENSION", where
);
1068 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1069 && !gfc_find_state (COMP_INTERFACE
))
1071 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1072 "at %L", name
, where
);
1076 attr
->codimension
= 1;
1077 return gfc_check_conflict (attr
, name
, where
);
1082 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1085 if (check_used (attr
, name
, where
))
1088 if (attr
->dimension
&& ! gfc_submodule_procedure(attr
))
1090 duplicate_attr ("DIMENSION", where
);
1094 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1095 && !gfc_find_state (COMP_INTERFACE
))
1097 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1098 "at %L", name
, where
);
1102 attr
->dimension
= 1;
1103 return gfc_check_conflict (attr
, name
, where
);
1108 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1111 if (check_used (attr
, name
, where
))
1114 if (attr
->contiguous
)
1116 duplicate_attr ("CONTIGUOUS", where
);
1120 attr
->contiguous
= 1;
1121 return gfc_check_conflict (attr
, name
, where
);
1126 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1129 if (check_used (attr
, NULL
, where
))
1134 duplicate_attr ("EXTERNAL", where
);
1138 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1141 attr
->proc_pointer
= 1;
1146 return gfc_check_conflict (attr
, NULL
, where
);
1151 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1154 if (check_used (attr
, NULL
, where
))
1157 if (attr
->intrinsic
)
1159 duplicate_attr ("INTRINSIC", where
);
1163 attr
->intrinsic
= 1;
1165 return gfc_check_conflict (attr
, NULL
, where
);
1170 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1173 if (check_used (attr
, NULL
, where
))
1178 duplicate_attr ("OPTIONAL", where
);
1183 return gfc_check_conflict (attr
, NULL
, where
);
1187 gfc_add_kind (symbol_attribute
*attr
, locus
*where
)
1191 duplicate_attr ("KIND", where
);
1196 return gfc_check_conflict (attr
, NULL
, where
);
1200 gfc_add_len (symbol_attribute
*attr
, locus
*where
)
1204 duplicate_attr ("LEN", where
);
1209 return gfc_check_conflict (attr
, NULL
, where
);
1214 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1217 if (check_used (attr
, NULL
, where
))
1220 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1221 && !gfc_find_state (COMP_INTERFACE
))
1222 && ! gfc_submodule_procedure(attr
))
1224 duplicate_attr ("POINTER", where
);
1228 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1229 || (attr
->if_source
== IFSRC_IFBODY
1230 && !gfc_find_state (COMP_INTERFACE
)))
1231 attr
->proc_pointer
= 1;
1235 return gfc_check_conflict (attr
, NULL
, where
);
1240 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1243 if (check_used (attr
, NULL
, where
))
1246 attr
->cray_pointer
= 1;
1247 return gfc_check_conflict (attr
, NULL
, where
);
1252 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1255 if (check_used (attr
, NULL
, where
))
1258 if (attr
->cray_pointee
)
1260 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1261 " statements", where
);
1265 attr
->cray_pointee
= 1;
1266 return gfc_check_conflict (attr
, NULL
, where
);
1271 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1273 if (check_used (attr
, name
, where
))
1276 if (attr
->is_protected
)
1278 if (!gfc_notify_std (GFC_STD_LEGACY
,
1279 "Duplicate PROTECTED attribute specified at %L",
1284 attr
->is_protected
= 1;
1285 return gfc_check_conflict (attr
, name
, where
);
1290 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1293 if (check_used (attr
, name
, where
))
1297 return gfc_check_conflict (attr
, name
, where
);
1302 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1306 if (check_used (attr
, name
, where
))
1309 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1311 gfc_error ("SAVE attribute at %L cannot be specified in a PURE "
1312 "procedure", where
);
1316 if (s
== SAVE_EXPLICIT
)
1317 gfc_unset_implicit_pure (NULL
);
1319 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
1320 && (flag_automatic
|| pedantic
))
1324 gfc_error ("Duplicate SAVE attribute specified near %C");
1328 if (!gfc_notify_std (GFC_STD_LEGACY
, "Duplicate SAVE attribute "
1329 "specified at %L", where
))
1334 return gfc_check_conflict (attr
, name
, where
);
1339 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1342 if (check_used (attr
, name
, where
))
1347 if (!gfc_notify_std (GFC_STD_LEGACY
,
1348 "Duplicate VALUE attribute specified at %L",
1354 return gfc_check_conflict (attr
, name
, where
);
1359 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1361 /* No check_used needed as 11.2.1 of the F2003 standard allows
1362 that the local identifier made accessible by a use statement can be
1363 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1365 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1366 if (!gfc_notify_std (GFC_STD_LEGACY
,
1367 "Duplicate VOLATILE attribute specified at %L",
1371 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1372 shall not appear in a pure subprogram.
1374 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1375 construct within a pure subprogram, shall not have the SAVE or
1376 VOLATILE attribute. */
1377 if (gfc_pure (NULL
))
1379 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1380 "PURE procedure", where
);
1385 attr
->volatile_
= 1;
1386 attr
->volatile_ns
= gfc_current_ns
;
1387 return gfc_check_conflict (attr
, name
, where
);
1392 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1394 /* No check_used needed as 11.2.1 of the F2003 standard allows
1395 that the local identifier made accessible by a use statement can be
1396 given a ASYNCHRONOUS attribute. */
1398 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1399 if (!gfc_notify_std (GFC_STD_LEGACY
,
1400 "Duplicate ASYNCHRONOUS attribute specified at %L",
1404 attr
->asynchronous
= 1;
1405 attr
->asynchronous_ns
= gfc_current_ns
;
1406 return gfc_check_conflict (attr
, name
, where
);
1411 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1414 if (check_used (attr
, name
, where
))
1417 if (attr
->threadprivate
)
1419 duplicate_attr ("THREADPRIVATE", where
);
1423 attr
->threadprivate
= 1;
1424 return gfc_check_conflict (attr
, name
, where
);
1429 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1433 if (check_used (attr
, name
, where
))
1436 if (attr
->omp_declare_target
)
1439 attr
->omp_declare_target
= 1;
1440 return gfc_check_conflict (attr
, name
, where
);
1445 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1449 if (check_used (attr
, name
, where
))
1452 if (attr
->omp_declare_target_link
)
1455 attr
->omp_declare_target_link
= 1;
1456 return gfc_check_conflict (attr
, name
, where
);
1461 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1464 if (check_used (attr
, name
, where
))
1467 if (attr
->oacc_declare_create
)
1470 attr
->oacc_declare_create
= 1;
1471 return gfc_check_conflict (attr
, name
, where
);
1476 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1479 if (check_used (attr
, name
, where
))
1482 if (attr
->oacc_declare_copyin
)
1485 attr
->oacc_declare_copyin
= 1;
1486 return gfc_check_conflict (attr
, name
, where
);
1491 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1494 if (check_used (attr
, name
, where
))
1497 if (attr
->oacc_declare_deviceptr
)
1500 attr
->oacc_declare_deviceptr
= 1;
1501 return gfc_check_conflict (attr
, name
, where
);
1506 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1509 if (check_used (attr
, name
, where
))
1512 if (attr
->oacc_declare_device_resident
)
1515 attr
->oacc_declare_device_resident
= 1;
1516 return gfc_check_conflict (attr
, name
, where
);
1521 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1524 if (check_used (attr
, NULL
, where
))
1529 duplicate_attr ("TARGET", where
);
1534 return gfc_check_conflict (attr
, NULL
, where
);
1539 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1542 if (check_used (attr
, name
, where
))
1545 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1547 return gfc_check_conflict (attr
, name
, where
);
1552 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1555 if (check_used (attr
, name
, where
))
1558 /* Duplicate attribute already checked for. */
1559 attr
->in_common
= 1;
1560 return gfc_check_conflict (attr
, name
, where
);
1565 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1568 /* Duplicate attribute already checked for. */
1569 attr
->in_equivalence
= 1;
1570 if (!gfc_check_conflict (attr
, name
, where
))
1573 if (attr
->flavor
== FL_VARIABLE
)
1576 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1581 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1584 if (check_used (attr
, name
, where
))
1588 return gfc_check_conflict (attr
, name
, where
);
1593 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1596 attr
->in_namelist
= 1;
1597 return gfc_check_conflict (attr
, name
, where
);
1602 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1605 if (check_used (attr
, name
, where
))
1609 return gfc_check_conflict (attr
, name
, where
);
1614 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1617 if (check_used (attr
, NULL
, where
))
1620 if (attr
->elemental
)
1622 duplicate_attr ("ELEMENTAL", where
);
1626 attr
->elemental
= 1;
1627 return gfc_check_conflict (attr
, NULL
, where
);
1632 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1635 if (check_used (attr
, NULL
, where
))
1640 duplicate_attr ("PURE", where
);
1645 return gfc_check_conflict (attr
, NULL
, where
);
1650 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1653 if (check_used (attr
, NULL
, where
))
1656 if (attr
->recursive
)
1658 duplicate_attr ("RECURSIVE", where
);
1662 attr
->recursive
= 1;
1663 return gfc_check_conflict (attr
, NULL
, where
);
1668 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1671 if (check_used (attr
, name
, where
))
1676 duplicate_attr ("ENTRY", where
);
1681 return gfc_check_conflict (attr
, name
, where
);
1686 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1689 if (attr
->flavor
!= FL_PROCEDURE
1690 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1694 return gfc_check_conflict (attr
, name
, where
);
1699 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1702 if (attr
->flavor
!= FL_PROCEDURE
1703 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1706 attr
->subroutine
= 1;
1708 /* If we are looking at a BLOCK DATA statement and we encounter a
1709 name with a leading underscore (which must be
1710 compiler-generated), do not check. See PR 84394. */
1712 if (name
&& *name
!= '_' && gfc_current_state () != COMP_BLOCK_DATA
)
1713 return gfc_check_conflict (attr
, name
, where
);
1720 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1723 if (attr
->flavor
!= FL_PROCEDURE
1724 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1728 return gfc_check_conflict (attr
, name
, where
);
1733 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1736 if (check_used (attr
, NULL
, where
))
1739 if (attr
->flavor
!= FL_PROCEDURE
1740 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1743 if (attr
->procedure
)
1745 duplicate_attr ("PROCEDURE", where
);
1749 attr
->procedure
= 1;
1751 return gfc_check_conflict (attr
, NULL
, where
);
1756 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1760 duplicate_attr ("ABSTRACT", where
);
1766 return gfc_check_conflict (attr
, NULL
, where
);
1770 /* Flavors are special because some flavors are not what Fortran
1771 considers attributes and can be reaffirmed multiple times. */
1774 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1778 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1779 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1780 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1783 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1786 /* Copying a procedure dummy argument for a module procedure in a
1787 submodule results in the flavor being copied and would result in
1788 an error without this. */
1789 if (attr
->flavor
== f
&& f
== FL_PROCEDURE
1790 && gfc_new_block
&& gfc_new_block
->abr_modproc_decl
)
1793 if (attr
->flavor
!= FL_UNKNOWN
)
1796 where
= &gfc_current_locus
;
1799 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1800 gfc_code2string (flavors
, attr
->flavor
), name
,
1801 gfc_code2string (flavors
, f
), where
);
1803 gfc_error ("%s attribute conflicts with %s attribute at %L",
1804 gfc_code2string (flavors
, attr
->flavor
),
1805 gfc_code2string (flavors
, f
), where
);
1812 return gfc_check_conflict (attr
, name
, where
);
1817 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1818 const char *name
, locus
*where
)
1821 if (check_used (attr
, name
, where
))
1824 if (attr
->flavor
!= FL_PROCEDURE
1825 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1829 where
= &gfc_current_locus
;
1831 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
1832 && attr
->access
== ACCESS_UNKNOWN
)
1834 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1835 && !gfc_notification_std (GFC_STD_F2008
))
1836 gfc_error ("%s procedure at %L is already declared as %s "
1837 "procedure. \nF2008: A pointer function assignment "
1838 "is ambiguous if it is the first executable statement "
1839 "after the specification block. Please add any other "
1840 "kind of executable statement before it. FIXME",
1841 gfc_code2string (procedures
, t
), where
,
1842 gfc_code2string (procedures
, attr
->proc
));
1844 gfc_error ("%s procedure at %L is already declared as %s "
1845 "procedure", gfc_code2string (procedures
, t
), where
,
1846 gfc_code2string (procedures
, attr
->proc
));
1853 /* Statement functions are always scalar and functions. */
1854 if (t
== PROC_ST_FUNCTION
1855 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1856 || attr
->dimension
))
1859 return gfc_check_conflict (attr
, name
, where
);
1864 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1867 if (check_used (attr
, NULL
, where
))
1870 if (attr
->intent
== INTENT_UNKNOWN
)
1872 attr
->intent
= intent
;
1873 return gfc_check_conflict (attr
, NULL
, where
);
1877 where
= &gfc_current_locus
;
1879 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1880 gfc_intent_string (attr
->intent
),
1881 gfc_intent_string (intent
), where
);
1887 /* No checks for use-association in public and private statements. */
1890 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1891 const char *name
, locus
*where
)
1894 if (attr
->access
== ACCESS_UNKNOWN
1895 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1897 attr
->access
= access
;
1898 return gfc_check_conflict (attr
, name
, where
);
1902 where
= &gfc_current_locus
;
1903 gfc_error ("ACCESS specification at %L was already specified", where
);
1909 /* Set the is_bind_c field for the given symbol_attribute. */
1912 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1913 int is_proc_lang_bind_spec
)
1916 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1917 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1918 "variables or common blocks", where
);
1919 else if (attr
->is_bind_c
)
1920 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1922 attr
->is_bind_c
= 1;
1925 where
= &gfc_current_locus
;
1927 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1930 return gfc_check_conflict (attr
, name
, where
);
1934 /* Set the extension field for the given symbol_attribute. */
1937 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1940 where
= &gfc_current_locus
;
1942 if (attr
->extension
)
1943 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1945 attr
->extension
= 1;
1947 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1955 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1956 gfc_formal_arglist
* formal
, locus
*where
)
1958 if (check_used (&sym
->attr
, sym
->name
, where
))
1961 /* Skip the following checks in the case of a module_procedures in a
1962 submodule since they will manifestly fail. */
1963 if (sym
->attr
.module_procedure
== 1
1964 && source
== IFSRC_DECL
)
1968 where
= &gfc_current_locus
;
1970 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1971 && sym
->attr
.if_source
!= IFSRC_DECL
)
1973 gfc_error ("Symbol %qs at %L already has an explicit interface",
1978 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1980 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1981 "body", sym
->name
, where
);
1986 sym
->formal
= formal
;
1987 sym
->attr
.if_source
= source
;
1993 /* Add a type to a symbol. */
1996 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
2002 where
= &gfc_current_locus
;
2005 type
= sym
->result
->ts
.type
;
2007 type
= sym
->ts
.type
;
2009 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
2010 type
= sym
->ns
->proc_name
->ts
.type
;
2012 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
2013 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
2014 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
2015 && !sym
->attr
.module_procedure
)
2017 if (sym
->attr
.use_assoc
)
2018 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2019 "use-associated at %L", sym
->name
, where
, sym
->module
,
2021 else if (sym
->attr
.function
&& sym
->attr
.result
)
2022 gfc_error ("Symbol %qs at %L already has basic type of %s",
2023 sym
->ns
->proc_name
->name
, where
, gfc_basic_typename (type
));
2025 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
2026 where
, gfc_basic_typename (type
));
2030 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
2032 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2033 sym
->name
, where
, gfc_basic_typename (ts
->type
));
2037 flavor
= sym
->attr
.flavor
;
2039 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
2040 || flavor
== FL_LABEL
2041 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
2042 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
2044 gfc_error ("Symbol %qs at %L cannot have a type",
2045 sym
->ns
->proc_name
? sym
->ns
->proc_name
->name
: sym
->name
,
2055 /* Clears all attributes. */
2058 gfc_clear_attr (symbol_attribute
*attr
)
2060 memset (attr
, 0, sizeof (symbol_attribute
));
2064 /* Check for missing attributes in the new symbol. Currently does
2065 nothing, but it's not clear that it is unnecessary yet. */
2068 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2069 locus
*where ATTRIBUTE_UNUSED
)
2076 /* Copy an attribute to a symbol attribute, bit by bit. Some
2077 attributes have a lot of side-effects but cannot be present given
2078 where we are called from, so we ignore some bits. */
2081 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2083 int is_proc_lang_bind_spec
;
2085 /* In line with the other attributes, we only add bits but do not remove
2086 them; cf. also PR 41034. */
2087 dest
->ext_attr
|= src
->ext_attr
;
2089 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2092 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2094 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2096 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2098 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2100 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2102 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2104 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2106 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2108 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2110 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2112 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2114 if (src
->threadprivate
2115 && !gfc_add_threadprivate (dest
, NULL
, where
))
2117 if (src
->omp_declare_target
2118 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2120 if (src
->omp_declare_target_link
2121 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2123 if (src
->oacc_declare_create
2124 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2126 if (src
->oacc_declare_copyin
2127 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2129 if (src
->oacc_declare_deviceptr
2130 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2132 if (src
->oacc_declare_device_resident
2133 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2135 if (src
->target
&& !gfc_add_target (dest
, where
))
2137 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2139 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2144 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2147 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2150 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2152 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2154 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2157 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2159 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2161 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2163 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2166 if (src
->flavor
!= FL_UNKNOWN
2167 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2170 if (src
->intent
!= INTENT_UNKNOWN
2171 && !gfc_add_intent (dest
, src
->intent
, where
))
2174 if (src
->access
!= ACCESS_UNKNOWN
2175 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2178 if (!gfc_missing_attr (dest
, where
))
2181 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2183 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2186 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2188 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2191 if (src
->is_c_interop
)
2192 dest
->is_c_interop
= 1;
2196 if (src
->external
&& !gfc_add_external (dest
, where
))
2198 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2200 if (src
->proc_pointer
)
2201 dest
->proc_pointer
= 1;
2210 /* A function to generate a dummy argument symbol using that from the
2211 interface declaration. Can be used for the result symbol as well if
2215 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2219 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2223 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2226 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2227 &gfc_current_locus
))
2230 if ((*dsym
)->attr
.dimension
)
2231 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2233 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2235 if ((*dsym
) != NULL
&& !result
2236 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2237 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2239 else if ((*dsym
) != NULL
&& result
2240 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2241 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2248 /************** Component name management ************/
2250 /* Component names of a derived type form their own little namespaces
2251 that are separate from all other spaces. The space is composed of
2252 a singly linked list of gfc_component structures whose head is
2253 located in the parent symbol. */
2256 /* Add a component name to a symbol. The call fails if the name is
2257 already present. On success, the component pointer is modified to
2258 point to the additional component structure. */
2261 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2262 gfc_component
**component
)
2264 gfc_component
*p
, *tail
;
2266 /* Check for existing components with the same name, but not for union
2267 components or containers. Unions and maps are anonymous so they have
2268 unique internal names which will never conflict.
2269 Don't use gfc_find_component here because it calls gfc_use_derived,
2270 but the derived type may not be fully defined yet. */
2273 for (p
= sym
->components
; p
; p
= p
->next
)
2275 if (strcmp (p
->name
, name
) == 0)
2277 gfc_error ("Component %qs at %C already declared at %L",
2285 if (sym
->attr
.extension
2286 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2287 name
, true, true, NULL
))
2289 gfc_error ("Component %qs at %C already in the parent type "
2290 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2294 /* Allocate a new component. */
2295 p
= gfc_get_component ();
2298 sym
->components
= p
;
2302 p
->name
= gfc_get_string ("%s", name
);
2303 p
->loc
= gfc_current_locus
;
2304 p
->ts
.type
= BT_UNKNOWN
;
2311 /* Recursive function to switch derived types of all symbol in a
2315 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2323 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2324 sym
->ts
.u
.derived
= to
;
2326 switch_types (st
->left
, from
, to
);
2327 switch_types (st
->right
, from
, to
);
2331 /* This subroutine is called when a derived type is used in order to
2332 make the final determination about which version to use. The
2333 standard requires that a type be defined before it is 'used', but
2334 such types can appear in IMPLICIT statements before the actual
2335 definition. 'Using' in this context means declaring a variable to
2336 be that type or using the type constructor.
2338 If a type is used and the components haven't been defined, then we
2339 have to have a derived type in a parent unit. We find the node in
2340 the other namespace and point the symtree node in this namespace to
2341 that node. Further reference to this name point to the correct
2342 node. If we can't find the node in a parent namespace, then we have
2345 This subroutine takes a pointer to a symbol node and returns a
2346 pointer to the translated node or NULL for an error. Usually there
2347 is no translation and we return the node we were passed. */
2350 gfc_use_derived (gfc_symbol
*sym
)
2360 if (sym
->attr
.unlimited_polymorphic
)
2363 if (sym
->attr
.generic
)
2364 sym
= gfc_find_dt_in_generic (sym
);
2366 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2367 return sym
; /* Already defined. */
2369 if (sym
->ns
->parent
== NULL
)
2372 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2374 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2378 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2381 /* Get rid of symbol sym, translating all references to s. */
2382 for (i
= 0; i
< GFC_LETTERS
; i
++)
2384 t
= &sym
->ns
->default_type
[i
];
2385 if (t
->u
.derived
== sym
)
2389 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2394 /* Unlink from list of modified symbols. */
2395 gfc_commit_symbol (sym
);
2397 switch_types (sym
->ns
->sym_root
, sym
, s
);
2399 /* TODO: Also have to replace sym -> s in other lists like
2400 namelists, common lists and interface lists. */
2401 gfc_free_symbol (sym
);
2406 gfc_error ("Derived type %qs at %C is being used before it is defined",
2412 /* Find all derived types in the uppermost namespace that have a component
2413 a component called name and stash them in the assoc field of an
2414 associate name variable.
2415 This is used to infer the derived type of an associate name, whose selector
2416 is a sibling derived type function that has not yet been parsed. Either
2417 the derived type is use associated in both contained and sibling procedures
2418 or it appears in the uppermost namespace. */
2422 find_derived_types (gfc_symbol
*sym
, gfc_symtree
*st
, const char *name
,
2423 bool contained
, bool stash
)
2425 if (st
->n
.sym
&& st
->n
.sym
->attr
.flavor
== FL_DERIVED
2426 && !st
->n
.sym
->attr
.is_class
2427 && ((contained
&& st
->n
.sym
->attr
.use_assoc
) || !contained
)
2428 && gfc_find_component (st
->n
.sym
, name
, true, true, NULL
))
2430 /* Do the stashing, if required. */
2434 if (sym
->assoc
->derived_types
)
2435 st
->n
.sym
->dt_next
= sym
->assoc
->derived_types
;
2436 sym
->assoc
->derived_types
= st
->n
.sym
;
2441 find_derived_types (sym
, st
->left
, name
, contained
, stash
);
2444 find_derived_types (sym
, st
->right
, name
, contained
, stash
);
2448 gfc_find_derived_types (gfc_symbol
*sym
, gfc_namespace
*ns
,
2449 const char *name
, bool stash
)
2451 gfc_namespace
*encompassing
= NULL
;
2452 gcc_assert (sym
->assoc
);
2457 if (!ns
->parent
->parent
&& ns
->proc_name
2458 && (ns
->proc_name
->attr
.function
|| ns
->proc_name
->attr
.subroutine
))
2463 /* Search the top level namespace first. */
2464 find_derived_types (sym
, ns
->sym_root
, name
, false, stash
);
2466 /* Then the encompassing namespace. */
2467 if (encompassing
&& encompassing
!= ns
)
2468 find_derived_types (sym
, encompassing
->sym_root
, name
, true, stash
);
2473 /* Find the component with the given name in the union type symbol.
2474 If ref is not NULL it will be set to the chain of components through which
2475 the component can actually be accessed. This is necessary for unions because
2476 intermediate structures may be maps, nested structures, or other unions,
2477 all of which may (or must) be 'anonymous' to user code. */
2479 static gfc_component
*
2480 find_union_component (gfc_symbol
*un
, const char *name
,
2481 bool noaccess
, gfc_ref
**ref
)
2483 gfc_component
*m
, *check
;
2484 gfc_ref
*sref
, *tmp
;
2486 for (m
= un
->components
; m
; m
= m
->next
)
2488 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2492 /* Found component somewhere in m; chain the refs together. */
2496 sref
= gfc_get_ref ();
2497 sref
->type
= REF_COMPONENT
;
2498 sref
->u
.c
.component
= m
;
2499 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2504 /* Other checks (such as access) were done in the recursive calls. */
2511 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2512 the number of total candidates in CANDIDATES_LEN. */
2515 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2517 size_t &candidates_len
)
2519 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2520 vec_push (candidates
, candidates_len
, p
->name
);
2524 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2527 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2529 char **candidates
= NULL
;
2530 size_t candidates_len
= 0;
2531 lookup_component_fuzzy_find_candidates (component
, candidates
,
2533 return gfc_closest_fuzzy_match (member
, candidates
);
2537 /* Given a derived type node and a component name, try to locate the
2538 component structure. Returns the NULL pointer if the component is
2539 not found or the components are private. If noaccess is set, no access
2540 checks are done. If silent is set, an error will not be generated if
2541 the component cannot be found or accessed.
2543 If ref is not NULL, *ref is set to represent the chain of components
2544 required to get to the ultimate component.
2546 If the component is simply a direct subcomponent, or is inherited from a
2547 parent derived type in the given derived type, this is a single ref with its
2548 component set to the returned component.
2550 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2551 when the component is found through an implicit chain of nested union and
2552 map components. Unions and maps are "anonymous" substructures in FORTRAN
2553 which cannot be explicitly referenced, but the reference chain must be
2554 considered as in C for backend translation to correctly compute layouts.
2555 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2558 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2559 bool noaccess
, bool silent
, gfc_ref
**ref
)
2561 gfc_component
*p
, *check
;
2562 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2564 if (name
== NULL
|| sym
== NULL
)
2567 if (sym
->attr
.flavor
== FL_DERIVED
)
2568 sym
= gfc_use_derived (sym
);
2570 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2575 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2576 if (sym
->attr
.flavor
== FL_UNION
)
2577 return find_union_component (sym
, name
, noaccess
, ref
);
2579 if (ref
) *ref
= NULL
;
2580 for (p
= sym
->components
; p
; p
= p
->next
)
2582 /* Nest search into union's maps. */
2583 if (p
->ts
.type
== BT_UNION
)
2585 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2591 sref
= gfc_get_ref ();
2592 sref
->type
= REF_COMPONENT
;
2593 sref
->u
.c
.component
= p
;
2594 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2601 else if (strcmp (p
->name
, name
) == 0)
2607 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2609 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2610 if (p
->attr
.access
== ACCESS_PRIVATE
||
2611 (p
->attr
.access
!= ACCESS_PUBLIC
2612 && sym
->component_access
== ACCESS_PRIVATE
2613 && !is_parent_comp
))
2616 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2623 && sym
->attr
.extension
2624 && sym
->components
->ts
.type
== BT_DERIVED
)
2626 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2627 noaccess
, silent
, ref
);
2628 /* Do not overwrite the error. */
2633 if (p
== NULL
&& !silent
)
2635 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2637 gfc_error ("%qs at %C is not a member of the %qs structure"
2638 "; did you mean %qs?",
2639 name
, sym
->name
, guessed
);
2641 gfc_error ("%qs at %C is not a member of the %qs structure",
2645 /* Component was found; build the ultimate component reference. */
2646 if (p
!= NULL
&& ref
)
2648 tmp
= gfc_get_ref ();
2649 tmp
->type
= REF_COMPONENT
;
2650 tmp
->u
.c
.component
= p
;
2652 /* Link the final component ref to the end of the chain of subrefs. */
2656 for (; sref
->next
; sref
= sref
->next
)
2668 /* Given a symbol, free all of the component structures and everything
2672 free_components (gfc_component
*p
)
2680 gfc_free_array_spec (p
->as
);
2681 gfc_free_expr (p
->initializer
);
2683 gfc_free_expr (p
->kind_expr
);
2685 gfc_free_actual_arglist (p
->param_list
);
2693 /******************** Statement label management ********************/
2695 /* Comparison function for statement labels, used for managing the
2699 compare_st_labels (void *a1
, void *b1
)
2701 int a
= ((gfc_st_label
*) a1
)->value
;
2702 int b
= ((gfc_st_label
*) b1
)->value
;
2708 /* Free a single gfc_st_label structure, making sure the tree is not
2709 messed up. This function is called only when some parse error
2713 gfc_free_st_label (gfc_st_label
*label
)
2719 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2721 if (label
->format
!= NULL
)
2722 gfc_free_expr (label
->format
);
2728 /* Free a whole tree of gfc_st_label structures. */
2731 free_st_labels (gfc_st_label
*label
)
2737 free_st_labels (label
->left
);
2738 free_st_labels (label
->right
);
2740 if (label
->format
!= NULL
)
2741 gfc_free_expr (label
->format
);
2746 /* Given a label number, search for and return a pointer to the label
2747 structure, creating it if it does not exist. */
2750 gfc_get_st_label (int labelno
)
2755 if (gfc_current_state () == COMP_DERIVED
)
2756 ns
= gfc_current_block ()->f2k_derived
;
2759 /* Find the namespace of the scoping unit:
2760 If we're in a BLOCK construct, jump to the parent namespace. */
2761 ns
= gfc_current_ns
;
2762 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2766 /* First see if the label is already in this namespace. */
2770 if (lp
->value
== labelno
)
2773 if (lp
->value
< labelno
)
2779 lp
= XCNEW (gfc_st_label
);
2781 lp
->value
= labelno
;
2782 lp
->defined
= ST_LABEL_UNKNOWN
;
2783 lp
->referenced
= ST_LABEL_UNKNOWN
;
2786 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2792 /* Called when a statement with a statement label is about to be
2793 accepted. We add the label to the list of the current namespace,
2794 making sure it hasn't been defined previously and referenced
2798 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2802 labelno
= lp
->value
;
2804 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2805 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2806 &lp
->where
, label_locus
);
2809 lp
->where
= *label_locus
;
2813 case ST_LABEL_FORMAT
:
2814 if (lp
->referenced
== ST_LABEL_TARGET
2815 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2816 gfc_error ("Label %d at %C already referenced as branch target",
2819 lp
->defined
= ST_LABEL_FORMAT
;
2823 case ST_LABEL_TARGET
:
2824 case ST_LABEL_DO_TARGET
:
2825 if (lp
->referenced
== ST_LABEL_FORMAT
)
2826 gfc_error ("Label %d at %C already referenced as a format label",
2831 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2832 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2833 "DO termination statement which is not END DO"
2834 " or CONTINUE with label %d at %C", labelno
))
2839 lp
->defined
= ST_LABEL_BAD_TARGET
;
2840 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2846 /* Reference a label. Given a label and its type, see if that
2847 reference is consistent with what is known about that label,
2848 updating the unknown state. Returns false if something goes
2852 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2854 gfc_sl_type label_type
;
2861 labelno
= lp
->value
;
2863 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2864 label_type
= lp
->defined
;
2867 label_type
= lp
->referenced
;
2868 lp
->where
= gfc_current_locus
;
2871 if (label_type
== ST_LABEL_FORMAT
2872 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2874 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2879 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2880 || label_type
== ST_LABEL_BAD_TARGET
)
2881 && type
== ST_LABEL_FORMAT
)
2883 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2888 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2889 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2890 "Shared DO termination label %d at %C", labelno
))
2893 if (type
== ST_LABEL_DO_TARGET
2894 && !gfc_notify_std (GFC_STD_F2018_OBS
, "Labeled DO statement "
2895 "at %L", &gfc_current_locus
))
2898 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2899 lp
->referenced
= type
;
2907 /************** Symbol table management subroutines ****************/
2909 /* Basic details: Fortran 95 requires a potentially unlimited number
2910 of distinct namespaces when compiling a program unit. This case
2911 occurs during a compilation of internal subprograms because all of
2912 the internal subprograms must be read before we can start
2913 generating code for the host.
2915 Given the tricky nature of the Fortran grammar, we must be able to
2916 undo changes made to a symbol table if the current interpretation
2917 of a statement is found to be incorrect. Whenever a symbol is
2918 looked up, we make a copy of it and link to it. All of these
2919 symbols are kept in a vector so that we can commit or
2920 undo the changes at a later time.
2922 A symtree may point to a symbol node outside of its namespace. In
2923 this case, that symbol has been used as a host associated variable
2924 at some previous time. */
2926 /* Allocate a new namespace structure. Copies the implicit types from
2927 PARENT if PARENT_TYPES is set. */
2930 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2937 ns
= XCNEW (gfc_namespace
);
2938 ns
->sym_root
= NULL
;
2939 ns
->uop_root
= NULL
;
2940 ns
->tb_sym_root
= NULL
;
2941 ns
->finalizers
= NULL
;
2942 ns
->default_access
= ACCESS_UNKNOWN
;
2943 ns
->parent
= parent
;
2945 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2947 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2948 ns
->tb_op
[in
] = NULL
;
2951 /* Initialize default implicit types. */
2952 for (i
= 'a'; i
<= 'z'; i
++)
2954 ns
->set_flag
[i
- 'a'] = 0;
2955 ts
= &ns
->default_type
[i
- 'a'];
2957 if (parent_types
&& ns
->parent
!= NULL
)
2959 /* Copy parent settings. */
2960 *ts
= ns
->parent
->default_type
[i
- 'a'];
2964 if (flag_implicit_none
!= 0)
2970 if ('i' <= i
&& i
<= 'n')
2972 ts
->type
= BT_INTEGER
;
2973 ts
->kind
= gfc_default_integer_kind
;
2978 ts
->kind
= gfc_default_real_kind
;
2988 /* Comparison function for symtree nodes. */
2991 compare_symtree (void *_st1
, void *_st2
)
2993 gfc_symtree
*st1
, *st2
;
2995 st1
= (gfc_symtree
*) _st1
;
2996 st2
= (gfc_symtree
*) _st2
;
2998 return strcmp (st1
->name
, st2
->name
);
3002 /* Allocate a new symtree node and associate it with the new symbol. */
3005 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
3009 st
= XCNEW (gfc_symtree
);
3010 st
->name
= gfc_get_string ("%s", name
);
3012 gfc_insert_bbt (root
, st
, compare_symtree
);
3017 /* Delete a symbol from the tree. Does not free the symbol itself! */
3020 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
3022 gfc_symtree st
, *st0
;
3025 /* Submodules are marked as mod.submod. When freeing a submodule
3026 symbol, the symtree only has "submod", so adjust that here. */
3028 p
= strrchr(name
, '.');
3034 st
.name
= gfc_get_string ("%s", p
);
3035 st0
= (gfc_symtree
*) gfc_delete_bbt (root
, &st
, compare_symtree
);
3041 /* Given a root symtree node and a name, try to find the symbol within
3042 the namespace. Returns NULL if the symbol is not found. */
3045 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
3051 c
= strcmp (name
, st
->name
);
3055 st
= (c
< 0) ? st
->left
: st
->right
;
3062 /* Return a symtree node with a name that is guaranteed to be unique
3063 within the namespace and corresponds to an illegal fortran name. */
3066 gfc_get_unique_symtree (gfc_namespace
*ns
)
3068 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3069 static int serial
= 0;
3071 sprintf (name
, "@%d", serial
++);
3072 return gfc_new_symtree (&ns
->sym_root
, name
);
3076 /* Given a name find a user operator node, creating it if it doesn't
3077 exist. These are much simpler than symbols because they can't be
3078 ambiguous with one another. */
3081 gfc_get_uop (const char *name
)
3085 gfc_namespace
*ns
= gfc_current_ns
;
3089 st
= gfc_find_symtree (ns
->uop_root
, name
);
3093 st
= gfc_new_symtree (&ns
->uop_root
, name
);
3095 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
3096 uop
->name
= gfc_get_string ("%s", name
);
3097 uop
->access
= ACCESS_UNKNOWN
;
3104 /* Given a name find the user operator node. Returns NULL if it does
3108 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3113 ns
= gfc_current_ns
;
3115 st
= gfc_find_symtree (ns
->uop_root
, name
);
3116 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3120 /* Update a symbol's common_block field, and take care of the associated
3121 memory management. */
3124 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3126 if (sym
->common_block
== common_block
)
3129 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3131 sym
->common_block
->refs
--;
3132 if (sym
->common_block
->refs
== 0)
3133 free (sym
->common_block
);
3135 sym
->common_block
= common_block
;
3139 /* Remove a gfc_symbol structure and everything it points to. */
3142 gfc_free_symbol (gfc_symbol
*&sym
)
3148 gfc_free_array_spec (sym
->as
);
3150 free_components (sym
->components
);
3152 gfc_free_expr (sym
->value
);
3154 gfc_free_namelist (sym
->namelist
);
3156 if (sym
->ns
!= sym
->formal_ns
)
3157 gfc_free_namespace (sym
->formal_ns
);
3159 if (!sym
->attr
.generic_copy
)
3160 gfc_free_interface (sym
->generic
);
3162 gfc_free_formal_arglist (sym
->formal
);
3164 gfc_free_namespace (sym
->f2k_derived
);
3166 set_symbol_common_block (sym
, NULL
);
3168 if (sym
->param_list
)
3169 gfc_free_actual_arglist (sym
->param_list
);
3176 /* Returns true if the symbol SYM has, through its FORMAL_NS field, a reference
3177 to itself which should be eliminated for the symbol memory to be released
3178 via normal reference counting.
3180 The implementation is crucial as it controls the proper release of symbols,
3181 especially (contained) procedure symbols, which can represent a lot of memory
3182 through the namespace of their body.
3184 We try to avoid freeing too much memory (causing dangling pointers), to not
3185 leak too much (wasting memory), and to avoid expensive walks of the symbol
3186 tree (which would be the correct way to check for a cycle). */
3189 cyclic_reference_break_needed (gfc_symbol
*sym
)
3191 /* Normal symbols don't reference themselves. */
3192 if (sym
->formal_ns
== nullptr)
3195 /* Procedures at the root of the file do have a self reference, but they don't
3196 have a reference in a parent namespace preventing the release of the
3197 procedure namespace, so they can use the normal reference counting. */
3198 if (sym
->formal_ns
== sym
->ns
)
3201 /* If sym->refs == 1, we can use normal reference counting. If sym->refs > 2,
3202 the symbol won't be freed anyway, with or without cyclic reference. */
3206 /* Procedure symbols host-associated from a module in submodules are special,
3207 because the namespace of the procedure block in the submodule is different
3208 from the FORMAL_NS namespace generated by host-association. So there are
3209 two different namespaces representing the same procedure namespace. As
3210 FORMAL_NS comes from host-association, which only imports symbols visible
3211 from the outside (dummy arguments basically), we can assume there is no
3212 self reference through FORMAL_NS in that case. */
3213 if (sym
->attr
.host_assoc
&& sym
->attr
.used_in_submodule
)
3216 /* We can assume that contained procedures have cyclic references, because
3217 the symbol of the procedure itself is accessible in the procedure body
3218 namespace. So we assume that symbols with a formal namespace different
3219 from the declaration namespace and two references, one of which is about
3220 to be removed, are procedures with just the self reference left. At this
3221 point, the symbol SYM matches that pattern, so we return true here to
3222 permit the release of SYM. */
3227 /* Decrease the reference counter and free memory when we reach zero.
3228 Returns true if the symbol has been freed, false otherwise. */
3231 gfc_release_symbol (gfc_symbol
*&sym
)
3236 if (cyclic_reference_break_needed (sym
))
3238 /* As formal_ns contains a reference to sym, delete formal_ns just
3239 before the deletion of sym. */
3240 gfc_namespace
*ns
= sym
->formal_ns
;
3241 sym
->formal_ns
= NULL
;
3242 gfc_free_namespace (ns
);
3249 gcc_assert (sym
->refs
== 0);
3250 gfc_free_symbol (sym
);
3255 /* Allocate and initialize a new symbol node. */
3258 gfc_new_symbol (const char *name
, gfc_namespace
*ns
, locus
*where
)
3262 p
= XCNEW (gfc_symbol
);
3264 gfc_clear_ts (&p
->ts
);
3265 gfc_clear_attr (&p
->attr
);
3267 p
->declared_at
= where
? *where
: gfc_current_locus
;
3268 p
->name
= gfc_get_string ("%s", name
);
3274 /* Generate an error if a symbol is ambiguous, and set the error flag
3278 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3281 if (st
->n
.sym
->error
)
3284 if (st
->n
.sym
->module
)
3285 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3286 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3288 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3289 "from current program unit", name
, st
->n
.sym
->name
);
3291 st
->n
.sym
->error
= 1;
3295 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3296 selector on the stack. If yes, replace it by the corresponding temporary. */
3299 select_type_insert_tmp (gfc_symtree
**st
)
3301 gfc_select_type_stack
*stack
= select_type_stack
;
3302 for (; stack
; stack
= stack
->prev
)
3303 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3306 select_type_insert_tmp (st
);
3312 /* Look for a symtree in the current procedure -- that is, go up to
3313 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3316 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3320 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3324 if (!ns
->construct_entities
)
3333 /* Search for a symtree starting in the current namespace, resorting to
3334 any parent namespaces if requested by a nonzero parent_flag.
3335 Returns true if the name is ambiguous. */
3338 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3339 gfc_symtree
**result
)
3344 ns
= gfc_current_ns
;
3348 st
= gfc_find_symtree (ns
->sym_root
, name
);
3351 select_type_insert_tmp (&st
);
3354 /* Ambiguous generic interfaces are permitted, as long
3355 as the specific interfaces are different. */
3356 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3358 ambiguous_symbol (name
, st
);
3368 /* Don't escape an interface block. */
3369 if (ns
&& !ns
->has_import_set
3370 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3377 if (gfc_current_state() == COMP_DERIVED
3378 && gfc_current_block ()->attr
.pdt_template
)
3380 gfc_symbol
*der
= gfc_current_block ();
3381 for (; der
; der
= gfc_get_derived_super_type (der
))
3383 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3385 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3400 /* Same, but returns the symbol instead. */
3403 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3404 gfc_symbol
**result
)
3409 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3414 *result
= st
->n
.sym
;
3420 /* Tells whether there is only one set of changes in the stack. */
3423 single_undo_checkpoint_p (void)
3425 if (latest_undo_chgset
== &default_undo_chgset_var
)
3427 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3432 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3437 /* Save symbol with the information necessary to back it out. */
3440 gfc_save_symbol_data (gfc_symbol
*sym
)
3445 if (!single_undo_checkpoint_p ())
3447 /* If there is more than one change set, look for the symbol in the
3448 current one. If it is found there, we can reuse it. */
3449 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3452 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3456 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3459 s
= XCNEW (gfc_symbol
);
3461 sym
->old_symbol
= s
;
3464 latest_undo_chgset
->syms
.safe_push (sym
);
3468 /* Given a name, find a symbol, or create it if it does not exist yet
3469 in the current namespace. If the symbol is found we make sure that
3472 The integer return code indicates
3474 1 The symbol name was ambiguous
3475 2 The name meant to be established was already host associated.
3477 So if the return value is nonzero, then an error was issued. */
3480 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3481 bool allow_subroutine
, locus
*where
)
3486 /* This doesn't usually happen during resolution. */
3488 ns
= gfc_current_ns
;
3490 /* Try to find the symbol in ns. */
3491 st
= gfc_find_symtree (ns
->sym_root
, name
);
3493 if (st
== NULL
&& ns
->omp_udr_ns
)
3496 st
= gfc_find_symtree (ns
->sym_root
, name
);
3501 /* If not there, create a new symbol. */
3502 p
= gfc_new_symbol (name
, ns
, where
);
3504 /* Add to the list of tentative symbols. */
3505 p
->old_symbol
= NULL
;
3508 latest_undo_chgset
->syms
.safe_push (p
);
3510 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3517 /* Make sure the existing symbol is OK. Ambiguous
3518 generic interfaces are permitted, as long as the
3519 specific interfaces are different. */
3520 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3522 ambiguous_symbol (name
, st
);
3527 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3528 && !(allow_subroutine
&& p
->attr
.subroutine
)
3529 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3530 && (ns
->has_import_set
|| p
->attr
.imported
)))
3532 /* Symbol is from another namespace. */
3533 gfc_error ("Symbol %qs at %C has already been host associated",
3540 /* Copy in case this symbol is changed. */
3541 gfc_save_symbol_data (p
);
3550 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
,
3556 i
= gfc_get_sym_tree (name
, ns
, &st
, false, where
);
3561 *result
= st
->n
.sym
;
3568 /* Subroutine that searches for a symbol, creating it if it doesn't
3569 exist, but tries to host-associate the symbol if possible. */
3572 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
, locus
*where
)
3577 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3581 gfc_save_symbol_data (st
->n
.sym
);
3586 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3596 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false, where
);
3601 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
, locus
*where
)
3604 gfc_symtree
*st
= NULL
;
3606 i
= gfc_get_ha_sym_tree (name
, &st
, where
);
3609 *result
= st
->n
.sym
;
3617 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3618 head->name as the common_root symtree's name might be mangled. */
3620 static gfc_symtree
*
3621 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3624 gfc_symtree
*result
;
3629 if (st
->n
.common
== head
)
3632 result
= find_common_symtree (st
->left
, head
);
3634 result
= find_common_symtree (st
->right
, head
);
3640 /* Restore previous state of symbol. Just copy simple stuff. */
3643 restore_old_symbol (gfc_symbol
*p
)
3648 old
= p
->old_symbol
;
3650 p
->ts
.type
= old
->ts
.type
;
3651 p
->ts
.kind
= old
->ts
.kind
;
3653 p
->attr
= old
->attr
;
3655 if (p
->value
!= old
->value
)
3657 gcc_checking_assert (old
->value
== NULL
);
3658 gfc_free_expr (p
->value
);
3662 if (p
->as
!= old
->as
)
3665 gfc_free_array_spec (p
->as
);
3669 p
->generic
= old
->generic
;
3670 p
->component_access
= old
->component_access
;
3672 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3674 gfc_free_namelist (p
->namelist
);
3679 if (p
->namelist_tail
!= old
->namelist_tail
)
3681 gfc_free_namelist (old
->namelist_tail
->next
);
3682 old
->namelist_tail
->next
= NULL
;
3686 p
->namelist_tail
= old
->namelist_tail
;
3688 if (p
->formal
!= old
->formal
)
3690 gfc_free_formal_arglist (p
->formal
);
3691 p
->formal
= old
->formal
;
3694 set_symbol_common_block (p
, old
->common_block
);
3695 p
->common_head
= old
->common_head
;
3697 p
->old_symbol
= old
->old_symbol
;
3702 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3703 the structure itself. */
3706 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3713 /* Given a change set pointer, free its target's contents and update it with
3714 the address of the previous change set. Note that only the contents are
3715 freed, not the target itself (the contents' container). It is not a problem
3716 as the latter will be a local variable usually. */
3719 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3721 free_undo_change_set_data (*cs
);
3726 static void free_old_symbol (gfc_symbol
*sym
);
3729 /* Merges the current change set into the previous one. The changes themselves
3730 are left untouched; only one checkpoint is forgotten. */
3733 gfc_drop_last_undo_checkpoint (void)
3738 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3740 /* No need to loop in this case. */
3741 if (s
->old_symbol
== NULL
)
3744 /* Remove the duplicate symbols. */
3745 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3748 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3750 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3751 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3752 shall contain from now on the backup symbol for S as it was
3753 at the checkpoint before. */
3754 if (s
->old_symbol
->gfc_new
)
3756 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3757 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3758 free_old_symbol (s
);
3761 restore_old_symbol (s
->old_symbol
);
3766 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3767 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3769 pop_undo_change_set (latest_undo_chgset
);
3773 /* Remove the reference to the symbol SYM in the symbol tree held by NS
3774 and free SYM if the last reference to it has been removed.
3775 Returns whether the symbol has been freed. */
3778 delete_symbol_from_ns (gfc_symbol
*sym
, gfc_namespace
*ns
)
3783 /* The derived type is saved in the symtree with the first
3784 letter capitalized; the all lower-case version to the
3785 derived type contains its associated generic function. */
3786 const char *sym_name
= gfc_fl_struct (sym
->attr
.flavor
)
3787 ? gfc_dt_upper_string (sym
->name
)
3790 gfc_delete_symtree (&ns
->sym_root
, sym_name
);
3792 return gfc_release_symbol (sym
);
3796 /* Undoes all the changes made to symbols since the previous checkpoint.
3797 This subroutine is made simpler due to the fact that attributes are
3798 never removed once added. */
3801 gfc_restore_last_undo_checkpoint (void)
3806 FOR_EACH_VEC_ELT_REVERSE (latest_undo_chgset
->syms
, i
, p
)
3808 /* Symbol in a common block was new. Or was old and just put in common */
3810 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3812 /* If the symbol was added to any common block, it
3813 needs to be removed to stop the resolver looking
3814 for a (possibly) dead symbol. */
3815 if (p
->common_block
->head
== p
&& !p
->common_next
)
3817 gfc_symtree st
, *st0
;
3818 st0
= find_common_symtree (p
->ns
->common_root
,
3822 st
.name
= st0
->name
;
3823 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3828 if (p
->common_block
->head
== p
)
3829 p
->common_block
->head
= p
->common_next
;
3832 gfc_symbol
*cparent
, *csym
;
3834 cparent
= p
->common_block
->head
;
3835 csym
= cparent
->common_next
;
3840 csym
= csym
->common_next
;
3843 gcc_assert(cparent
->common_next
== p
);
3844 cparent
->common_next
= csym
->common_next
;
3846 p
->common_next
= NULL
;
3850 bool freed
= delete_symbol_from_ns (p
, p
->ns
);
3852 /* If the symbol is a procedure (function or subroutine), remove
3853 it from the procedure body namespace as well as from the outer
3856 && p
->formal_ns
!= p
->ns
)
3857 freed
= delete_symbol_from_ns (p
, p
->formal_ns
);
3859 /* If the formal_ns field has not been set yet, the previous
3860 conditional does nothing. In that case, we can assume that
3861 gfc_current_ns is the procedure body namespace, and remove the
3862 symbol from there. */
3864 && gfc_current_ns
!= p
->ns
3865 && gfc_current_ns
!= p
->formal_ns
)
3866 freed
= delete_symbol_from_ns (p
, gfc_current_ns
);
3869 restore_old_symbol (p
);
3872 latest_undo_chgset
->syms
.truncate (0);
3873 latest_undo_chgset
->tbps
.truncate (0);
3875 if (!single_undo_checkpoint_p ())
3876 pop_undo_change_set (latest_undo_chgset
);
3880 /* Makes sure that there is only one set of changes; in other words we haven't
3881 forgotten to pair a call to gfc_new_checkpoint with a call to either
3882 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3885 enforce_single_undo_checkpoint (void)
3887 gcc_checking_assert (single_undo_checkpoint_p ());
3891 /* Undoes all the changes made to symbols in the current statement. */
3894 gfc_undo_symbols (void)
3896 enforce_single_undo_checkpoint ();
3897 gfc_restore_last_undo_checkpoint ();
3901 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3902 components of old_symbol that might need deallocation are the "allocatables"
3903 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3904 namelist_tail. In case these differ between old_symbol and sym, it's just
3905 because sym->namelist has gotten a few more items. */
3908 free_old_symbol (gfc_symbol
*sym
)
3911 if (sym
->old_symbol
== NULL
)
3914 if (sym
->old_symbol
->as
!= NULL
3915 && sym
->old_symbol
->as
!= sym
->as
3916 && !(sym
->ts
.type
== BT_CLASS
3917 && sym
->ts
.u
.derived
->attr
.is_class
3918 && sym
->old_symbol
->as
== CLASS_DATA (sym
)->as
))
3919 gfc_free_array_spec (sym
->old_symbol
->as
);
3921 if (sym
->old_symbol
->value
!= sym
->value
)
3922 gfc_free_expr (sym
->old_symbol
->value
);
3924 if (sym
->old_symbol
->formal
!= sym
->formal
)
3925 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3927 free (sym
->old_symbol
);
3928 sym
->old_symbol
= NULL
;
3932 /* Makes the changes made in the current statement permanent-- gets
3933 rid of undo information. */
3936 gfc_commit_symbols (void)
3939 gfc_typebound_proc
*tbp
;
3942 enforce_single_undo_checkpoint ();
3944 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3948 free_old_symbol (p
);
3950 latest_undo_chgset
->syms
.truncate (0);
3952 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3954 latest_undo_chgset
->tbps
.truncate (0);
3958 /* Makes the changes made in one symbol permanent -- gets rid of undo
3962 gfc_commit_symbol (gfc_symbol
*sym
)
3967 enforce_single_undo_checkpoint ();
3969 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3972 latest_undo_chgset
->syms
.unordered_remove (i
);
3979 free_old_symbol (sym
);
3983 /* Recursively free trees containing type-bound procedures. */
3986 free_tb_tree (gfc_symtree
*t
)
3991 free_tb_tree (t
->left
);
3992 free_tb_tree (t
->right
);
3994 /* TODO: Free type-bound procedure u.generic */
4001 /* Recursive function that deletes an entire tree and all the common
4002 head structures it points to. */
4005 free_common_tree (gfc_symtree
* common_tree
)
4007 if (common_tree
== NULL
)
4010 free_common_tree (common_tree
->left
);
4011 free_common_tree (common_tree
->right
);
4017 /* Recursive function that deletes an entire tree and all the common
4018 head structures it points to. */
4021 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
4023 if (omp_udr_tree
== NULL
)
4026 free_omp_udr_tree (omp_udr_tree
->left
);
4027 free_omp_udr_tree (omp_udr_tree
->right
);
4029 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
4030 free (omp_udr_tree
);
4034 /* Recursive function that deletes an entire tree and all the user
4035 operator nodes that it contains. */
4038 free_uop_tree (gfc_symtree
*uop_tree
)
4040 if (uop_tree
== NULL
)
4043 free_uop_tree (uop_tree
->left
);
4044 free_uop_tree (uop_tree
->right
);
4046 gfc_free_interface (uop_tree
->n
.uop
->op
);
4047 free (uop_tree
->n
.uop
);
4052 /* Recursive function that deletes an entire tree and all the symbols
4053 that it contains. */
4056 free_sym_tree (gfc_symtree
*sym_tree
)
4058 if (sym_tree
== NULL
)
4061 free_sym_tree (sym_tree
->left
);
4062 free_sym_tree (sym_tree
->right
);
4064 gfc_release_symbol (sym_tree
->n
.sym
);
4069 /* Free the gfc_equiv_info's. */
4072 gfc_free_equiv_infos (gfc_equiv_info
*s
)
4076 gfc_free_equiv_infos (s
->next
);
4081 /* Free the gfc_equiv_lists. */
4084 gfc_free_equiv_lists (gfc_equiv_list
*l
)
4088 gfc_free_equiv_lists (l
->next
);
4089 gfc_free_equiv_infos (l
->equiv
);
4094 /* Free a finalizer procedure list. */
4097 gfc_free_finalizer (gfc_finalizer
* el
)
4101 gfc_release_symbol (el
->proc_sym
);
4107 gfc_free_finalizer_list (gfc_finalizer
* list
)
4111 gfc_finalizer
* current
= list
;
4113 gfc_free_finalizer (current
);
4118 /* Create a new gfc_charlen structure and add it to a namespace.
4119 If 'old_cl' is given, the newly created charlen will be a copy of it. */
4122 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
4126 cl
= gfc_get_charlen ();
4131 cl
->length
= gfc_copy_expr (old_cl
->length
);
4132 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
4133 cl
->backend_decl
= old_cl
->backend_decl
;
4134 cl
->passed_length
= old_cl
->passed_length
;
4135 cl
->resolved
= old_cl
->resolved
;
4138 /* Put into namespace. */
4139 cl
->next
= ns
->cl_list
;
4146 /* Free the charlen list from cl to end (end is not freed).
4147 Free the whole list if end is NULL. */
4150 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
4154 for (; cl
!= end
; cl
= cl2
)
4159 gfc_free_expr (cl
->length
);
4165 /* Free entry list structs. */
4168 free_entry_list (gfc_entry_list
*el
)
4170 gfc_entry_list
*next
;
4177 free_entry_list (next
);
4181 /* Free a namespace structure and everything below it. Interface
4182 lists associated with intrinsic operators are not freed. These are
4183 taken care of when a specific name is freed. */
4186 gfc_free_namespace (gfc_namespace
*&ns
)
4188 gfc_namespace
*p
, *q
;
4190 gfc_was_finalized
*f
;
4199 gcc_assert (ns
->refs
== 0);
4201 gfc_free_statements (ns
->code
);
4203 free_sym_tree (ns
->sym_root
);
4204 free_uop_tree (ns
->uop_root
);
4205 free_common_tree (ns
->common_root
);
4206 free_omp_udr_tree (ns
->omp_udr_root
);
4207 free_tb_tree (ns
->tb_sym_root
);
4208 free_tb_tree (ns
->tb_uop_root
);
4209 gfc_free_finalizer_list (ns
->finalizers
);
4210 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4211 gfc_free_omp_declare_variant_list (ns
->omp_declare_variant
);
4212 gfc_free_charlen (ns
->cl_list
, NULL
);
4213 free_st_labels (ns
->st_labels
);
4215 free_entry_list (ns
->entries
);
4216 gfc_free_equiv (ns
->equiv
);
4217 gfc_free_equiv_lists (ns
->equiv_lists
);
4218 gfc_free_use_stmts (ns
->use_stmts
);
4220 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4221 gfc_free_interface (ns
->op
[i
]);
4223 gfc_free_data (ns
->data
);
4225 /* Free all the expr + component combinations that have been
4227 f
= ns
->was_finalized
;
4230 gfc_was_finalized
* current
= f
;
4234 if (ns
->omp_assumes
)
4236 free (ns
->omp_assumes
->absent
);
4237 free (ns
->omp_assumes
->contains
);
4238 gfc_free_expr_list (ns
->omp_assumes
->holds
);
4239 free (ns
->omp_assumes
);
4245 /* Recursively free any contained namespaces. */
4250 gfc_free_namespace (q
);
4256 gfc_symbol_init_2 (void)
4259 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4264 gfc_symbol_done_2 (void)
4266 if (gfc_current_ns
!= NULL
)
4268 /* free everything from the root. */
4269 while (gfc_current_ns
->parent
!= NULL
)
4270 gfc_current_ns
= gfc_current_ns
->parent
;
4271 gfc_free_namespace (gfc_current_ns
);
4272 gfc_current_ns
= NULL
;
4274 gfc_derived_types
= NULL
;
4276 enforce_single_undo_checkpoint ();
4277 free_undo_change_set_data (*latest_undo_chgset
);
4281 /* Count how many nodes a symtree has. */
4284 count_st_nodes (const gfc_symtree
*st
)
4290 nodes
= count_st_nodes (st
->left
);
4292 nodes
+= count_st_nodes (st
->right
);
4298 /* Convert symtree tree into symtree vector. */
4301 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4306 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4307 st_vec
[node_cntr
++] = st
;
4308 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4314 /* Traverse namespace. As the functions might modify the symtree, we store the
4315 symtree as a vector and operate on this vector. Note: We assume that
4316 sym_func or st_func never deletes nodes from the symtree - only adding is
4317 allowed. Additionally, newly added nodes are not traversed. */
4320 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4321 void (*sym_func
) (gfc_symbol
*))
4323 gfc_symtree
**st_vec
;
4324 unsigned nodes
, i
, node_cntr
;
4326 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4327 nodes
= count_st_nodes (st
);
4328 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4330 fill_st_vector (st
, st_vec
, node_cntr
);
4335 for (i
= 0; i
< nodes
; i
++)
4336 st_vec
[i
]->n
.sym
->mark
= 0;
4337 for (i
= 0; i
< nodes
; i
++)
4338 if (!st_vec
[i
]->n
.sym
->mark
)
4340 (*sym_func
) (st_vec
[i
]->n
.sym
);
4341 st_vec
[i
]->n
.sym
->mark
= 1;
4345 for (i
= 0; i
< nodes
; i
++)
4346 (*st_func
) (st_vec
[i
]);
4350 /* Recursively traverse the symtree nodes. */
4353 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4355 do_traverse_symtree (st
, st_func
, NULL
);
4359 /* Call a given function for all symbols in the namespace. We take
4360 care that each gfc_symbol node is called exactly once. */
4363 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4365 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4369 /* Return TRUE when name is the name of an intrinsic type. */
4372 gfc_is_intrinsic_typename (const char *name
)
4374 if (strcmp (name
, "integer") == 0
4375 || strcmp (name
, "real") == 0
4376 || strcmp (name
, "character") == 0
4377 || strcmp (name
, "logical") == 0
4378 || strcmp (name
, "complex") == 0
4379 || strcmp (name
, "doubleprecision") == 0
4380 || strcmp (name
, "doublecomplex") == 0)
4387 /* Return TRUE if the symbol is an automatic variable. */
4390 gfc_is_var_automatic (gfc_symbol
*sym
)
4392 /* Pointer and allocatable variables are never automatic. */
4393 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4395 /* Check for arrays with non-constant size. */
4396 if (sym
->attr
.dimension
&& sym
->as
4397 && !gfc_is_compile_time_shape (sym
->as
))
4399 /* Check for non-constant length character variables. */
4400 if (sym
->ts
.type
== BT_CHARACTER
4402 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4404 /* Variables with explicit AUTOMATIC attribute. */
4405 if (sym
->attr
.automatic
)
4411 /* Given a symbol, mark it as SAVEd if it is allowed. */
4414 save_symbol (gfc_symbol
*sym
)
4417 if (sym
->attr
.use_assoc
)
4420 if (sym
->attr
.in_common
4421 || sym
->attr
.in_equivalence
4424 || sym
->attr
.flavor
!= FL_VARIABLE
)
4426 /* Automatic objects are not saved. */
4427 if (gfc_is_var_automatic (sym
))
4429 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4433 /* Mark those symbols which can be SAVEd as such. */
4436 gfc_save_all (gfc_namespace
*ns
)
4438 gfc_traverse_ns (ns
, save_symbol
);
4442 /* Make sure that no changes to symbols are pending. */
4445 gfc_enforce_clean_symbol_state(void)
4447 enforce_single_undo_checkpoint ();
4448 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4452 /************** Global symbol handling ************/
4455 /* Search a tree for the global symbol. */
4458 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4467 c
= strcmp (name
, symbol
->name
);
4471 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4478 /* Case insensitive search a tree for the global symbol. */
4481 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4490 c
= strcasecmp (name
, symbol
->name
);
4494 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4501 /* Compare two global symbols. Used for managing the BB tree. */
4504 gsym_compare (void *_s1
, void *_s2
)
4506 gfc_gsymbol
*s1
, *s2
;
4508 s1
= (gfc_gsymbol
*) _s1
;
4509 s2
= (gfc_gsymbol
*) _s2
;
4510 return strcmp (s1
->name
, s2
->name
);
4514 /* Get a global symbol, creating it if it doesn't exist. */
4517 gfc_get_gsymbol (const char *name
, bool bind_c
)
4521 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4525 s
= XCNEW (gfc_gsymbol
);
4526 s
->type
= GSYM_UNKNOWN
;
4527 s
->name
= gfc_get_string ("%s", name
);
4530 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4536 gfc_traverse_gsymbol (gfc_gsymbol
*gsym
,
4537 void (*do_something
) (gfc_gsymbol
*, void *),
4541 gfc_traverse_gsymbol (gsym
->left
, do_something
, data
);
4543 (*do_something
) (gsym
, data
);
4546 gfc_traverse_gsymbol (gsym
->right
, do_something
, data
);
4550 get_iso_c_binding_dt (int sym_id
)
4552 gfc_symbol
*dt_list
= gfc_derived_types
;
4554 /* Loop through the derived types in the name list, searching for
4555 the desired symbol from iso_c_binding. Search the parent namespaces
4556 if necessary and requested to (parent_flag). */
4559 while (dt_list
->dt_next
!= gfc_derived_types
)
4561 if (dt_list
->from_intmod
!= INTMOD_NONE
4562 && dt_list
->intmod_sym_id
== sym_id
)
4565 dt_list
= dt_list
->dt_next
;
4573 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4574 with C. This is necessary for any derived type that is BIND(C) and for
4575 derived types that are parameters to functions that are BIND(C). All
4576 fields of the derived type are required to be interoperable, and are tested
4577 for such. If an error occurs, the errors are reported here, allowing for
4578 multiple errors to be handled for a single derived type. */
4581 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4583 gfc_component
*curr_comp
= NULL
;
4584 bool is_c_interop
= false;
4587 if (derived_sym
== NULL
)
4588 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4589 "unexpectedly NULL");
4591 /* If we've already looked at this derived symbol, do not look at it again
4592 so we don't repeat warnings/errors. */
4593 if (derived_sym
->ts
.is_c_interop
)
4596 /* The derived type must have the BIND attribute to be interoperable
4597 J3/04-007, Section 15.2.3. */
4598 if (derived_sym
->attr
.is_bind_c
!= 1)
4600 derived_sym
->ts
.is_c_interop
= 0;
4601 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4602 "attribute to be C interoperable", derived_sym
->name
,
4603 &(derived_sym
->declared_at
));
4607 curr_comp
= derived_sym
->components
;
4609 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4610 empty struct. Section 15.2 in Fortran 2003 states: "The following
4611 subclauses define the conditions under which a Fortran entity is
4612 interoperable. If a Fortran entity is interoperable, an equivalent
4613 entity may be defined by means of C and the Fortran entity is said
4614 to be interoperable with the C entity. There does not have to be such
4615 an interoperating C entity."
4617 if (curr_comp
== NULL
)
4619 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4620 "and may be inaccessible by the C companion processor",
4621 derived_sym
->name
, &(derived_sym
->declared_at
));
4622 derived_sym
->ts
.is_c_interop
= 1;
4623 derived_sym
->attr
.is_bind_c
= 1;
4628 /* Initialize the derived type as being C interoperable.
4629 If we find an error in the components, this will be set false. */
4630 derived_sym
->ts
.is_c_interop
= 1;
4632 /* Loop through the list of components to verify that the kind of
4633 each is a C interoperable type. */
4636 /* The components cannot be pointers (fortran sense).
4637 J3/04-007, Section 15.2.3, C1505. */
4638 if (curr_comp
->attr
.pointer
!= 0)
4640 gfc_error ("Component %qs at %L cannot have the "
4641 "POINTER attribute because it is a member "
4642 "of the BIND(C) derived type %qs at %L",
4643 curr_comp
->name
, &(curr_comp
->loc
),
4644 derived_sym
->name
, &(derived_sym
->declared_at
));
4648 if (curr_comp
->attr
.proc_pointer
!= 0)
4650 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4651 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4652 &curr_comp
->loc
, derived_sym
->name
,
4653 &derived_sym
->declared_at
);
4657 /* The components cannot be allocatable.
4658 J3/04-007, Section 15.2.3, C1505. */
4659 if (curr_comp
->attr
.allocatable
!= 0)
4661 gfc_error ("Component %qs at %L cannot have the "
4662 "ALLOCATABLE attribute because it is a member "
4663 "of the BIND(C) derived type %qs at %L",
4664 curr_comp
->name
, &(curr_comp
->loc
),
4665 derived_sym
->name
, &(derived_sym
->declared_at
));
4669 /* BIND(C) derived types must have interoperable components. */
4670 if (curr_comp
->ts
.type
== BT_DERIVED
4671 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4672 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4674 /* This should be allowed; the draft says a derived-type cannot
4675 have type parameters if it is has the BIND attribute. Type
4676 parameters seem to be for making parameterized derived types.
4677 There's no need to verify the type if it is c_ptr/c_funptr. */
4678 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4682 /* Grab the typespec for the given component and test the kind. */
4683 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4687 /* Report warning and continue since not fatal. The
4688 draft does specify a constraint that requires all fields
4689 to interoperate, but if the user says real(4), etc., it
4690 may interoperate with *something* in C, but the compiler
4691 most likely won't know exactly what. Further, it may not
4692 interoperate with the same data type(s) in C if the user
4693 recompiles with different flags (e.g., -m32 and -m64 on
4694 x86_64 and using integer(4) to claim interop with a
4696 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4697 /* If the derived type is bind(c), all fields must be
4699 gfc_warning (OPT_Wc_binding_type
,
4700 "Component %qs in derived type %qs at %L "
4701 "may not be C interoperable, even though "
4702 "derived type %qs is BIND(C)",
4703 curr_comp
->name
, derived_sym
->name
,
4704 &(curr_comp
->loc
), derived_sym
->name
);
4705 else if (warn_c_binding_type
)
4706 /* If derived type is param to bind(c) routine, or to one
4707 of the iso_c_binding procs, it must be interoperable, so
4708 all fields must interop too. */
4709 gfc_warning (OPT_Wc_binding_type
,
4710 "Component %qs in derived type %qs at %L "
4711 "may not be C interoperable",
4712 curr_comp
->name
, derived_sym
->name
,
4717 curr_comp
= curr_comp
->next
;
4718 } while (curr_comp
!= NULL
);
4720 if (derived_sym
->attr
.sequence
!= 0)
4722 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4723 "attribute because it is BIND(C)", derived_sym
->name
,
4724 &(derived_sym
->declared_at
));
4728 /* Mark the derived type as not being C interoperable if we found an
4729 error. If there were only warnings, proceed with the assumption
4730 it's interoperable. */
4732 derived_sym
->ts
.is_c_interop
= 0;
4738 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4741 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4745 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4746 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4748 tmp_sym
->attr
.is_c_interop
= 1;
4749 tmp_sym
->attr
.is_bind_c
= 1;
4750 tmp_sym
->ts
.is_c_interop
= 1;
4751 tmp_sym
->ts
.is_iso_c
= 1;
4752 tmp_sym
->ts
.type
= BT_DERIVED
;
4753 tmp_sym
->ts
.f90_type
= BT_VOID
;
4754 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4755 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4757 /* Set the c_address field of c_null_ptr and c_null_funptr to
4758 the value of NULL. */
4759 tmp_sym
->value
= gfc_get_expr ();
4760 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4761 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4762 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4763 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4764 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4765 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4766 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4767 c
->expr
->ts
.is_iso_c
= 1;
4773 /* Add a formal argument, gfc_formal_arglist, to the
4774 end of the given list of arguments. Set the reference to the
4775 provided symbol, param_sym, in the argument. */
4778 add_formal_arg (gfc_formal_arglist
**head
,
4779 gfc_formal_arglist
**tail
,
4780 gfc_formal_arglist
*formal_arg
,
4781 gfc_symbol
*param_sym
)
4783 /* Put in list, either as first arg or at the tail (curr arg). */
4785 *head
= *tail
= formal_arg
;
4788 (*tail
)->next
= formal_arg
;
4789 (*tail
) = formal_arg
;
4792 (*tail
)->sym
= param_sym
;
4793 (*tail
)->next
= NULL
;
4799 /* Add a procedure interface to the given symbol (i.e., store a
4800 reference to the list of formal arguments). */
4803 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4806 sym
->formal
= formal
;
4807 sym
->attr
.if_source
= source
;
4811 /* Copy the formal args from an existing symbol, src, into a new
4812 symbol, dest. New formal args are created, and the description of
4813 each arg is set according to the existing ones. This function is
4814 used when creating procedure declaration variables from a procedure
4815 declaration statement (see match_proc_decl()) to create the formal
4816 args based on the args of a given named interface.
4818 When an actual argument list is provided, skip the absent arguments
4819 unless copy_type is true.
4820 To be used together with gfc_se->ignore_optional. */
4823 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4824 gfc_actual_arglist
*actual
, bool copy_type
)
4826 gfc_formal_arglist
*head
= NULL
;
4827 gfc_formal_arglist
*tail
= NULL
;
4828 gfc_formal_arglist
*formal_arg
= NULL
;
4829 gfc_intrinsic_arg
*curr_arg
= NULL
;
4830 gfc_formal_arglist
*formal_prev
= NULL
;
4831 gfc_actual_arglist
*act_arg
= actual
;
4832 /* Save current namespace so we can change it for formal args. */
4833 gfc_namespace
*parent_ns
= gfc_current_ns
;
4835 /* Create a new namespace, which will be the formal ns (namespace
4836 of the formal args). */
4837 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4838 gfc_current_ns
->proc_name
= dest
;
4840 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4842 /* Skip absent arguments. */
4845 gcc_assert (act_arg
!= NULL
);
4846 if (act_arg
->expr
== NULL
)
4848 act_arg
= act_arg
->next
;
4852 formal_arg
= gfc_get_formal_arglist ();
4853 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4855 /* May need to copy more info for the symbol. */
4856 if (copy_type
&& act_arg
->expr
!= NULL
)
4858 formal_arg
->sym
->ts
= act_arg
->expr
->ts
;
4859 if (act_arg
->expr
->rank
> 0)
4861 formal_arg
->sym
->attr
.dimension
= 1;
4862 formal_arg
->sym
->as
= gfc_get_array_spec();
4863 formal_arg
->sym
->as
->rank
= -1;
4864 formal_arg
->sym
->as
->type
= AS_ASSUMED_RANK
;
4866 if (act_arg
->name
&& strcmp (act_arg
->name
, "%VAL") == 0)
4867 formal_arg
->sym
->pass_as_value
= 1;
4870 formal_arg
->sym
->ts
= curr_arg
->ts
;
4872 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4873 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4874 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4875 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4876 formal_arg
->sym
->attr
.dummy
= 1;
4878 /* Do not treat an actual deferred-length character argument wrongly
4879 as template for the formal argument. */
4880 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
4881 && !(formal_arg
->sym
->attr
.allocatable
4882 || formal_arg
->sym
->attr
.pointer
))
4883 formal_arg
->sym
->ts
.deferred
= false;
4885 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4886 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4888 /* If this isn't the first arg, set up the next ptr. For the
4889 last arg built, the formal_arg->next will never get set to
4890 anything other than NULL. */
4891 if (formal_prev
!= NULL
)
4892 formal_prev
->next
= formal_arg
;
4894 formal_arg
->next
= NULL
;
4896 formal_prev
= formal_arg
;
4898 /* Add arg to list of formal args. */
4899 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4901 /* Validate changes. */
4902 gfc_commit_symbol (formal_arg
->sym
);
4904 act_arg
= act_arg
->next
;
4907 /* Add the interface to the symbol. */
4908 add_proc_interface (dest
, IFSRC_DECL
, head
);
4910 /* Store the formal namespace information. */
4911 if (dest
->formal
!= NULL
)
4912 /* The current ns should be that for the dest proc. */
4913 dest
->formal_ns
= gfc_current_ns
;
4914 /* Restore the current namespace to what it was on entry. */
4915 gfc_current_ns
= parent_ns
;
4920 std_for_isocbinding_symbol (int id
)
4924 #define NAMED_INTCST(a,b,c,d) \
4927 #include "iso-c-binding.def"
4930 #define NAMED_UINTCST(a,b,c,d) \
4933 #include "iso-c-binding.def"
4934 #undef NAMED_UINTCST
4936 #define NAMED_FUNCTION(a,b,c,d) \
4939 #define NAMED_SUBROUTINE(a,b,c,d) \
4942 #include "iso-c-binding.def"
4943 #undef NAMED_FUNCTION
4944 #undef NAMED_SUBROUTINE
4947 return GFC_STD_F2003
;
4951 /* Generate the given set of C interoperable kind objects, or all
4952 interoperable kinds. This function will only be given kind objects
4953 for valid iso_c_binding defined types because this is verified when
4954 the 'use' statement is parsed. If the user gives an 'only' clause,
4955 the specific kinds are looked up; if they don't exist, an error is
4956 reported. If the user does not give an 'only' clause, all
4957 iso_c_binding symbols are generated. If a list of specific kinds
4958 is given, it must have a NULL in the first empty spot to mark the
4959 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4960 point to the symtree for c_(fun)ptr. */
4963 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4964 const char *local_name
, gfc_symtree
*dt_symtree
,
4967 const char *const name
= (local_name
&& local_name
[0])
4968 ? local_name
: c_interop_kinds_table
[s
].name
;
4969 gfc_symtree
*tmp_symtree
;
4970 gfc_symbol
*tmp_sym
= NULL
;
4973 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4976 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4978 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4979 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4980 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4983 /* Already exists in this scope so don't re-add it. */
4984 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4985 && (!tmp_sym
->attr
.generic
4986 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4987 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4989 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4990 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4992 if (gfc_derived_types
)
4994 tmp_sym
->dt_next
= gfc_derived_types
->dt_next
;
4995 gfc_derived_types
->dt_next
= tmp_sym
;
4999 tmp_sym
->dt_next
= tmp_sym
;
5001 gfc_derived_types
= tmp_sym
;
5007 /* Create the sym tree in the current ns. */
5010 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
5011 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
5013 /* Add to the list of tentative symbols. */
5014 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
5015 tmp_sym
->old_symbol
= NULL
;
5017 tmp_sym
->gfc_new
= 1;
5019 tmp_symtree
->n
.sym
= tmp_sym
;
5024 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5025 gcc_assert (tmp_symtree
);
5026 tmp_sym
= tmp_symtree
->n
.sym
;
5029 /* Say what module this symbol belongs to. */
5030 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
5031 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5032 tmp_sym
->intmod_sym_id
= s
;
5033 tmp_sym
->attr
.is_iso_c
= 1;
5034 tmp_sym
->attr
.use_assoc
= 1;
5036 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
5037 || s
== ISOCBINDING_NULL_PTR
);
5042 #define NAMED_INTCST(a,b,c,d) case a :
5043 #define NAMED_UINTCST(a,b,c,d) case a :
5044 #define NAMED_REALCST(a,b,c,d) case a :
5045 #define NAMED_CMPXCST(a,b,c,d) case a :
5046 #define NAMED_LOGCST(a,b,c) case a :
5047 #define NAMED_CHARKNDCST(a,b,c) case a :
5048 #include "iso-c-binding.def"
5050 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5051 c_interop_kinds_table
[s
].value
);
5053 /* Initialize an integer constant expression node. */
5054 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
5055 tmp_sym
->ts
.type
= BT_INTEGER
;
5056 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
5058 /* Mark this type as a C interoperable one. */
5059 tmp_sym
->ts
.is_c_interop
= 1;
5060 tmp_sym
->ts
.is_iso_c
= 1;
5061 tmp_sym
->value
->ts
.is_c_interop
= 1;
5062 tmp_sym
->value
->ts
.is_iso_c
= 1;
5063 tmp_sym
->attr
.is_c_interop
= 1;
5065 /* Tell what f90 type this c interop kind is valid. */
5066 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
5071 #define NAMED_CHARCST(a,b,c) case a :
5072 #include "iso-c-binding.def"
5074 /* Initialize an integer constant expression node for the
5075 length of the character. */
5076 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
5077 &gfc_current_locus
, NULL
, 1);
5078 tmp_sym
->value
->ts
.is_c_interop
= 1;
5079 tmp_sym
->value
->ts
.is_iso_c
= 1;
5080 tmp_sym
->value
->value
.character
.length
= 1;
5081 tmp_sym
->value
->value
.character
.string
[0]
5082 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
5083 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5084 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
5087 /* May not need this in both attr and ts, but do need in
5088 attr for writing module file. */
5089 tmp_sym
->attr
.is_c_interop
= 1;
5091 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
5092 tmp_sym
->ts
.type
= BT_CHARACTER
;
5094 /* Need to set it to the C_CHAR kind. */
5095 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
5097 /* Mark this type as a C interoperable one. */
5098 tmp_sym
->ts
.is_c_interop
= 1;
5099 tmp_sym
->ts
.is_iso_c
= 1;
5101 /* Tell what f90 type this c interop kind is valid. */
5102 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
5106 case ISOCBINDING_PTR
:
5107 case ISOCBINDING_FUNPTR
:
5110 gfc_component
*tmp_comp
= NULL
;
5112 /* Generate real derived type. */
5117 const char *hidden_name
;
5118 gfc_interface
*intr
, *head
;
5120 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
5121 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
5123 gcc_assert (tmp_symtree
== NULL
);
5124 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
5125 dt_sym
= tmp_symtree
->n
.sym
;
5126 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
5127 ? "c_ptr" : "c_funptr");
5129 /* Generate an artificial generic function. */
5130 head
= tmp_sym
->generic
;
5131 intr
= gfc_get_interface ();
5133 intr
->where
= gfc_current_locus
;
5135 tmp_sym
->generic
= intr
;
5137 if (!tmp_sym
->attr
.generic
5138 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
5141 if (!tmp_sym
->attr
.function
5142 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
5146 /* Say what module this symbol belongs to. */
5147 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
5148 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5149 dt_sym
->intmod_sym_id
= s
;
5150 dt_sym
->attr
.use_assoc
= 1;
5152 /* Initialize an integer constant expression node. */
5153 dt_sym
->attr
.flavor
= FL_DERIVED
;
5154 dt_sym
->ts
.is_c_interop
= 1;
5155 dt_sym
->attr
.is_c_interop
= 1;
5156 dt_sym
->attr
.private_comp
= 1;
5157 dt_sym
->component_access
= ACCESS_PRIVATE
;
5158 dt_sym
->ts
.is_iso_c
= 1;
5159 dt_sym
->ts
.type
= BT_DERIVED
;
5160 dt_sym
->ts
.f90_type
= BT_VOID
;
5162 /* A derived type must have the bind attribute to be
5163 interoperable (J3/04-007, Section 15.2.3), even though
5164 the binding label is not used. */
5165 dt_sym
->attr
.is_bind_c
= 1;
5167 dt_sym
->attr
.referenced
= 1;
5168 dt_sym
->ts
.u
.derived
= dt_sym
;
5170 /* Add the symbol created for the derived type to the current ns. */
5171 if (gfc_derived_types
)
5173 dt_sym
->dt_next
= gfc_derived_types
->dt_next
;
5174 gfc_derived_types
->dt_next
= dt_sym
;
5178 dt_sym
->dt_next
= dt_sym
;
5180 gfc_derived_types
= dt_sym
;
5182 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
5183 if (tmp_comp
== NULL
)
5186 tmp_comp
->ts
.type
= BT_INTEGER
;
5188 /* Set this because the module will need to read/write this field. */
5189 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
5191 /* The kinds for c_ptr and c_funptr are the same. */
5192 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
5193 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
5194 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
5196 /* Mark the component as C interoperable. */
5197 tmp_comp
->ts
.is_c_interop
= 1;
5202 case ISOCBINDING_NULL_PTR
:
5203 case ISOCBINDING_NULL_FUNPTR
:
5204 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
5210 gfc_commit_symbol (tmp_sym
);
5215 /* Check that a symbol is already typed. If strict is not set, an untyped
5216 symbol is acceptable for non-standard-conforming mode. */
5219 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5220 bool strict
, locus where
)
5224 if (gfc_matching_prefix
)
5227 /* Check for the type and try to give it an implicit one. */
5228 if (sym
->ts
.type
== BT_UNKNOWN
5229 && !gfc_set_default_type (sym
, 0, ns
))
5233 gfc_error ("Symbol %qs is used before it is typed at %L",
5238 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5239 " it is typed at %L", sym
->name
, &where
))
5243 /* Everything is ok. */
5248 /* Construct a typebound-procedure structure. Those are stored in a tentative
5249 list and marked `error' until symbols are committed. */
5252 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5254 gfc_typebound_proc
*result
;
5256 result
= XCNEW (gfc_typebound_proc
);
5261 latest_undo_chgset
->tbps
.safe_push (result
);
5267 /* Get the super-type of a given derived type. */
5270 gfc_get_derived_super_type (gfc_symbol
* derived
)
5272 gcc_assert (derived
);
5274 if (derived
->attr
.generic
)
5275 derived
= gfc_find_dt_in_generic (derived
);
5277 if (!derived
->attr
.extension
)
5280 gcc_assert (derived
->components
);
5281 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5282 gcc_assert (derived
->components
->ts
.u
.derived
);
5284 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5285 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5287 return derived
->components
->ts
.u
.derived
;
5291 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5294 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5296 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5297 t2
= gfc_get_derived_super_type (t2
);
5298 return gfc_compare_derived_types (t1
, t2
);
5301 /* Check if parameterized derived type t2 is an instance of pdt template t1
5303 gfc_symbol *t1 -> pdt template to verify t2 against.
5304 gfc_symbol *t2 -> pdt instance to be verified.
5306 In decl.cc, gfc_get_pdt_instance, a pdt instance is given a 3 character
5307 prefix "Pdt", followed by an underscore list of the kind parameters,
5308 up to a maximum of 8 kind parameters. To verify if a PDT Type corresponds
5309 to the template, this functions extracts t2's derive_type name,
5310 and compares it to the derive_type name of t1 for compatibility.
5314 t2->name = Pdtf_2_2; extract out the 'f' and compare with t1->name. */
5317 gfc_pdt_is_instance_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5319 if ( !t1
->attr
.pdt_template
|| !t2
->attr
.pdt_type
)
5322 /* Limit comparison to length of t1->name to ignore new kind params. */
5323 if ( !(strncmp (&(t2
->name
[3]), t1
->name
, strlen (t1
->name
)) == 0) )
5329 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5330 If ts1 is nonpolymorphic, ts2 must be the same type.
5331 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5334 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5336 bool is_class1
= (ts1
->type
== BT_CLASS
);
5337 bool is_class2
= (ts2
->type
== BT_CLASS
);
5338 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5339 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5340 bool is_union1
= (ts1
->type
== BT_UNION
);
5341 bool is_union2
= (ts2
->type
== BT_UNION
);
5343 /* A boz-literal-constant has no type. */
5344 if (ts1
->type
== BT_BOZ
|| ts2
->type
== BT_BOZ
)
5348 && ts1
->u
.derived
->components
5349 && ((ts1
->u
.derived
->attr
.is_class
5350 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5351 .unlimited_polymorphic
)
5352 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5355 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5356 && !is_union1
&& !is_union2
)
5357 return (ts1
->type
== ts2
->type
);
5359 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5360 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5362 if (is_derived1
&& is_class2
)
5363 return gfc_compare_derived_types (ts1
->u
.derived
,
5364 ts2
->u
.derived
->attr
.is_class
?
5365 ts2
->u
.derived
->components
->ts
.u
.derived
5367 if (is_class1
&& is_derived2
)
5368 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5369 ts1
->u
.derived
->components
->ts
.u
.derived
5372 else if (is_class1
&& is_class2
)
5373 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5374 ts1
->u
.derived
->components
->ts
.u
.derived
5376 ts2
->u
.derived
->attr
.is_class
?
5377 ts2
->u
.derived
->components
->ts
.u
.derived
5384 /* Find the parent-namespace of the current function. If we're inside
5385 BLOCK constructs, it may not be the current one. */
5388 gfc_find_proc_namespace (gfc_namespace
* ns
)
5390 while (ns
->construct_entities
)
5400 /* Check if an associate-variable should be translated as an `implicit' pointer
5401 internally (if it is associated to a variable and not an array with
5405 gfc_is_associate_pointer (gfc_symbol
* sym
)
5410 if (sym
->ts
.type
== BT_CLASS
)
5413 if (sym
->ts
.type
== BT_CHARACTER
5415 && sym
->assoc
->target
5416 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5419 if (!sym
->assoc
->variable
)
5422 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
5423 && sym
->as
->type
!= AS_EXPLICIT
)
5431 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5433 gfc_interface
*intr
= NULL
;
5435 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5438 if (sym
->attr
.generic
)
5439 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5440 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5442 return intr
? intr
->sym
: NULL
;
5446 /* Get the dummy arguments from a procedure symbol. If it has been declared
5447 via a PROCEDURE statement with a named interface, ts.interface will be set
5448 and the arguments need to be taken from there. */
5450 gfc_formal_arglist
*
5451 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5453 gfc_formal_arglist
*dummies
;
5458 dummies
= sym
->formal
;
5459 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5460 dummies
= sym
->ts
.interface
->formal
;
5466 /* Given a procedure, returns the associated namespace.
5467 The resulting NS should match the condition NS->PROC_NAME == SYM. */
5470 gfc_get_procedure_ns (gfc_symbol
*sym
)
5473 && sym
->formal_ns
->proc_name
== sym
)
5474 return sym
->formal_ns
;
5476 /* The above should have worked in most cases. If it hasn't, try some other
5477 heuristics, eventually returning SYM->NS. */
5478 if (gfc_current_ns
->proc_name
== sym
)
5479 return gfc_current_ns
;
5481 /* For contained procedures, the symbol's NS field is the
5482 hosting namespace, not the procedure namespace. */
5483 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.contained
)
5484 for (gfc_namespace
*ns
= sym
->ns
->contained
; ns
; ns
= ns
->sibling
)
5485 if (ns
->proc_name
== sym
)
5489 for (gfc_formal_arglist
*f
= sym
->formal
; f
!= nullptr; f
= f
->next
)
5492 gfc_namespace
*ns
= f
->sym
->ns
;
5493 if (ns
&& ns
->proc_name
== sym
)
5501 /* Given a symbol, returns the namespace in which the symbol is specified.
5502 In most cases, it is the namespace hosting the symbol. This is the case
5503 for variables. For functions, however, it is the function namespace
5504 itself. This specification namespace is used to check conformance of
5505 array spec bound expressions. */
5508 gfc_get_spec_ns (gfc_symbol
*sym
)
5510 if (sym
->attr
.flavor
== FL_PROCEDURE
5511 && sym
->attr
.function
)
5513 if (sym
->result
== sym
)
5514 return gfc_get_procedure_ns (sym
);
5515 /* Generic and intrinsic functions can have a null result. */
5516 else if (sym
->result
!= nullptr)
5517 return sym
->result
->ns
;