1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
29 #include "constructor.h"
32 /* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
36 const mstring flavors
[] =
38 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
39 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
40 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
41 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
42 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
43 minit ("UNION", FL_UNION
), minit ("STRUCTURE", FL_STRUCT
),
47 const mstring procedures
[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
50 minit ("MODULE-PROC", PROC_MODULE
),
51 minit ("INTERNAL-PROC", PROC_INTERNAL
),
52 minit ("DUMMY-PROC", PROC_DUMMY
),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
59 const mstring intents
[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
62 minit ("IN", INTENT_IN
),
63 minit ("OUT", INTENT_OUT
),
64 minit ("INOUT", INTENT_INOUT
),
68 const mstring access_types
[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
71 minit ("PUBLIC", ACCESS_PUBLIC
),
72 minit ("PRIVATE", ACCESS_PRIVATE
),
76 const mstring ifsrc_types
[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN
),
79 minit ("DECL", IFSRC_DECL
),
80 minit ("BODY", IFSRC_IFBODY
)
83 const mstring save_status
[] =
85 minit ("UNKNOWN", SAVE_NONE
),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
90 /* Set the mstrings for DTIO procedure names. */
91 const mstring dtio_procs
[] =
93 minit ("_dtio_formatted_read", DTIO_RF
),
94 minit ("_dtio_formatted_write", DTIO_WF
),
95 minit ("_dtio_unformatted_read", DTIO_RUF
),
96 minit ("_dtio_unformatted_write", DTIO_WUF
),
99 /* This is to make sure the backend generates setup code in the correct
102 static int next_dummy_order
= 1;
105 gfc_namespace
*gfc_current_ns
;
106 gfc_namespace
*gfc_global_ns_list
;
108 gfc_gsymbol
*gfc_gsym_root
= NULL
;
110 gfc_dt_list
*gfc_derived_types
;
112 static gfc_undo_change_set default_undo_chgset_var
= { vNULL
, vNULL
, NULL
};
113 static gfc_undo_change_set
*latest_undo_chgset
= &default_undo_chgset_var
;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag
[GFC_LETTERS
];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (bool type
, bool external
, locus
*loc
)
132 gfc_current_ns
->has_implicit_none_export
= 1;
136 gfc_current_ns
->seen_implicit_none
= 1;
137 for (i
= 0; i
< GFC_LETTERS
; i
++)
139 if (gfc_current_ns
->set_flag
[i
])
141 gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
142 "IMPLICIT statement", loc
);
145 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
146 gfc_current_ns
->set_flag
[i
] = 1;
152 /* Reset the implicit range flags. */
155 gfc_clear_new_implicit (void)
159 for (i
= 0; i
< GFC_LETTERS
; i
++)
164 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
167 gfc_add_new_implicit_range (int c1
, int c2
)
174 for (i
= c1
; i
<= c2
; i
++)
178 gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
190 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
191 the new implicit types back into the existing types will work. */
194 gfc_merge_new_implicit (gfc_typespec
*ts
)
198 if (gfc_current_ns
->seen_implicit_none
)
200 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
204 for (i
= 0; i
< GFC_LETTERS
; i
++)
208 if (gfc_current_ns
->set_flag
[i
])
210 gfc_error ("Letter %qc already has an IMPLICIT type at %C",
215 gfc_current_ns
->default_type
[i
] = *ts
;
216 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
217 gfc_current_ns
->set_flag
[i
] = 1;
224 /* Given a symbol, return a pointer to the typespec for its default type. */
227 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
233 if (flag_allow_leading_underscore
&& letter
== '_')
234 gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
235 "gfortran developers, and should not be used for "
236 "implicitly typed variables");
238 if (letter
< 'a' || letter
> 'z')
239 gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name
);
244 return &ns
->default_type
[letter
- 'a'];
248 /* Recursively append candidate SYM to CANDIDATES. Store the number of
249 candidates in CANDIDATES_LEN. */
252 lookup_symbol_fuzzy_find_candidates (gfc_symtree
*sym
,
254 size_t &candidates_len
)
261 if (sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
&& sym
->n
.sym
->ts
.type
!= BT_PROCEDURE
)
262 vec_push (candidates
, candidates_len
, sym
->name
);
265 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
269 lookup_symbol_fuzzy_find_candidates (p
, candidates
, candidates_len
);
273 /* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
276 lookup_symbol_fuzzy (const char *sym_name
, gfc_symbol
*symbol
)
278 char **candidates
= NULL
;
279 size_t candidates_len
= 0;
280 lookup_symbol_fuzzy_find_candidates (symbol
->ns
->sym_root
, candidates
,
282 return gfc_closest_fuzzy_match (sym_name
, candidates
);
286 /* Given a pointer to a symbol, set its type according to the first
287 letter of its name. Fails if the letter in question has no default
291 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
295 if (sym
->ts
.type
!= BT_UNKNOWN
)
296 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
298 ts
= gfc_get_default_type (sym
->name
, ns
);
300 if (ts
->type
== BT_UNKNOWN
)
302 if (error_flag
&& !sym
->attr
.untyped
)
304 const char *guessed
= lookup_symbol_fuzzy (sym
->name
, sym
);
306 gfc_error ("Symbol %qs at %L has no IMPLICIT type"
307 "; did you mean %qs?",
308 sym
->name
, &sym
->declared_at
, guessed
);
310 gfc_error ("Symbol %qs at %L has no IMPLICIT type",
311 sym
->name
, &sym
->declared_at
);
312 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
319 sym
->attr
.implicit_type
= 1;
321 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
322 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
323 else if (ts
->type
== BT_CLASS
324 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
327 if (sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
329 /* BIND(C) variables should not be implicitly declared. */
330 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared BIND(C) "
331 "variable %qs at %L may not be C interoperable",
332 sym
->name
, &sym
->declared_at
);
333 sym
->ts
.f90_type
= sym
->ts
.type
;
336 if (sym
->attr
.dummy
!= 0)
338 if (sym
->ns
->proc_name
!= NULL
339 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
340 || sym
->ns
->proc_name
->attr
.function
!= 0)
341 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0
342 && warn_c_binding_type
)
344 /* Dummy args to a BIND(C) routine may not be interoperable if
345 they are implicitly typed. */
346 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared variable "
347 "%qs at %L may not be C interoperable but it is a "
348 "dummy argument to the BIND(C) procedure %qs at %L",
349 sym
->name
, &(sym
->declared_at
),
350 sym
->ns
->proc_name
->name
,
351 &(sym
->ns
->proc_name
->declared_at
));
352 sym
->ts
.f90_type
= sym
->ts
.type
;
360 /* This function is called from parse.c(parse_progunit) to check the
361 type of the function is not implicitly typed in the host namespace
362 and to implicitly type the function result, if necessary. */
365 gfc_check_function_type (gfc_namespace
*ns
)
367 gfc_symbol
*proc
= ns
->proc_name
;
369 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
372 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
374 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
))
376 if (proc
->result
!= proc
)
378 proc
->ts
= proc
->result
->ts
;
379 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
380 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
381 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
382 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
385 else if (!proc
->result
->attr
.proc_pointer
)
387 gfc_error ("Function result %qs at %L has no IMPLICIT type",
388 proc
->result
->name
, &proc
->result
->declared_at
);
389 proc
->result
->attr
.untyped
= 1;
395 /******************** Symbol attribute stuff *********************/
397 /* This is a generic conflict-checker. We do this to avoid having a
398 single conflict in two places. */
400 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402 #define conf_std(a, b, std) if (attr->a && attr->b)\
411 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
413 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
414 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
415 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
416 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
417 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
418 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
419 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
420 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
421 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
422 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
423 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
424 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
425 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
426 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
427 *proc_pointer
= "PROCEDURE POINTER", *abstract
= "ABSTRACT",
428 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
429 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC", *automatic
= "AUTOMATIC",
430 *pdt_len
= "LEN", *pdt_kind
= "KIND";
431 static const char *threadprivate
= "THREADPRIVATE";
432 static const char *omp_declare_target
= "OMP DECLARE TARGET";
433 static const char *omp_declare_target_link
= "OMP DECLARE TARGET LINK";
434 static const char *oacc_declare_copyin
= "OACC DECLARE COPYIN";
435 static const char *oacc_declare_create
= "OACC DECLARE CREATE";
436 static const char *oacc_declare_deviceptr
= "OACC DECLARE DEVICEPTR";
437 static const char *oacc_declare_device_resident
=
438 "OACC DECLARE DEVICE_RESIDENT";
444 where
= &gfc_current_locus
;
446 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
450 standard
= GFC_STD_F2003
;
454 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
457 a2
= attr
->allocatable
? allocatable
: pointer
;
458 standard
= GFC_STD_F2003
;
462 /* Check for attributes not allowed in a BLOCK DATA. */
463 if (gfc_current_state () == COMP_BLOCK_DATA
)
467 if (attr
->in_namelist
)
469 if (attr
->allocatable
)
475 if (attr
->access
== ACCESS_PRIVATE
)
477 if (attr
->access
== ACCESS_PUBLIC
)
479 if (attr
->intent
!= INTENT_UNKNOWN
)
485 ("%s attribute not allowed in BLOCK DATA program unit at %L",
491 if (attr
->save
== SAVE_EXPLICIT
)
494 conf (in_common
, save
);
496 conf (automatic
, save
);
498 switch (attr
->flavor
)
506 a1
= gfc_code2string (flavors
, attr
->flavor
);
510 gfc_error ("Namelist group name at %L cannot have the "
511 "SAVE attribute", where
);
514 /* Conflicts between SAVE and PROCEDURE will be checked at
515 resolution stage, see "resolve_fl_procedure". */
522 /* The copying of procedure dummy arguments for module procedures in
523 a submodule occur whilst the current state is COMP_CONTAINS. It
524 is necessary, therefore, to let this through. */
526 && (attr
->function
|| attr
->subroutine
)
527 && gfc_current_state () == COMP_CONTAINS
528 && !(gfc_new_block
&& gfc_new_block
->abr_modproc_decl
))
529 gfc_error_now ("internal procedure %qs at %L conflicts with "
530 "DUMMY argument", name
, where
);
533 conf (dummy
, intrinsic
);
534 conf (dummy
, threadprivate
);
535 conf (dummy
, omp_declare_target
);
536 conf (dummy
, omp_declare_target_link
);
537 conf (pointer
, target
);
538 conf (pointer
, intrinsic
);
539 conf (pointer
, elemental
);
540 conf (pointer
, codimension
);
541 conf (allocatable
, elemental
);
543 conf (in_common
, automatic
);
544 conf (in_equivalence
, automatic
);
545 conf (result
, automatic
);
546 conf (use_assoc
, automatic
);
547 conf (dummy
, automatic
);
549 conf (target
, external
);
550 conf (target
, intrinsic
);
552 if (!attr
->if_source
)
553 conf (external
, dimension
); /* See Fortran 95's R504. */
555 conf (external
, intrinsic
);
556 conf (entry
, intrinsic
);
558 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
559 conf (external
, subroutine
);
561 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
562 "Procedure pointer at %C"))
565 conf (allocatable
, pointer
);
566 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
567 conf_std (allocatable
, function
, GFC_STD_F2003
);
568 conf_std (allocatable
, result
, GFC_STD_F2003
);
569 conf (elemental
, recursive
);
571 conf (in_common
, dummy
);
572 conf (in_common
, allocatable
);
573 conf (in_common
, codimension
);
574 conf (in_common
, result
);
576 conf (in_equivalence
, use_assoc
);
577 conf (in_equivalence
, codimension
);
578 conf (in_equivalence
, dummy
);
579 conf (in_equivalence
, target
);
580 conf (in_equivalence
, pointer
);
581 conf (in_equivalence
, function
);
582 conf (in_equivalence
, result
);
583 conf (in_equivalence
, entry
);
584 conf (in_equivalence
, allocatable
);
585 conf (in_equivalence
, threadprivate
);
586 conf (in_equivalence
, omp_declare_target
);
587 conf (in_equivalence
, omp_declare_target_link
);
588 conf (in_equivalence
, oacc_declare_create
);
589 conf (in_equivalence
, oacc_declare_copyin
);
590 conf (in_equivalence
, oacc_declare_deviceptr
);
591 conf (in_equivalence
, oacc_declare_device_resident
);
592 conf (in_equivalence
, is_bind_c
);
594 conf (dummy
, result
);
595 conf (entry
, result
);
596 conf (generic
, result
);
597 conf (generic
, omp_declare_target
);
598 conf (generic
, omp_declare_target_link
);
600 conf (function
, subroutine
);
602 if (!function
&& !subroutine
)
603 conf (is_bind_c
, dummy
);
605 conf (is_bind_c
, cray_pointer
);
606 conf (is_bind_c
, cray_pointee
);
607 conf (is_bind_c
, codimension
);
608 conf (is_bind_c
, allocatable
);
609 conf (is_bind_c
, elemental
);
611 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
612 Parameter conflict caught below. Also, value cannot be specified
613 for a dummy procedure. */
615 /* Cray pointer/pointee conflicts. */
616 conf (cray_pointer
, cray_pointee
);
617 conf (cray_pointer
, dimension
);
618 conf (cray_pointer
, codimension
);
619 conf (cray_pointer
, contiguous
);
620 conf (cray_pointer
, pointer
);
621 conf (cray_pointer
, target
);
622 conf (cray_pointer
, allocatable
);
623 conf (cray_pointer
, external
);
624 conf (cray_pointer
, intrinsic
);
625 conf (cray_pointer
, in_namelist
);
626 conf (cray_pointer
, function
);
627 conf (cray_pointer
, subroutine
);
628 conf (cray_pointer
, entry
);
630 conf (cray_pointee
, allocatable
);
631 conf (cray_pointee
, contiguous
);
632 conf (cray_pointee
, codimension
);
633 conf (cray_pointee
, intent
);
634 conf (cray_pointee
, optional
);
635 conf (cray_pointee
, dummy
);
636 conf (cray_pointee
, target
);
637 conf (cray_pointee
, intrinsic
);
638 conf (cray_pointee
, pointer
);
639 conf (cray_pointee
, entry
);
640 conf (cray_pointee
, in_common
);
641 conf (cray_pointee
, in_equivalence
);
642 conf (cray_pointee
, threadprivate
);
643 conf (cray_pointee
, omp_declare_target
);
644 conf (cray_pointee
, omp_declare_target_link
);
645 conf (cray_pointee
, oacc_declare_create
);
646 conf (cray_pointee
, oacc_declare_copyin
);
647 conf (cray_pointee
, oacc_declare_deviceptr
);
648 conf (cray_pointee
, oacc_declare_device_resident
);
651 conf (data
, function
);
653 conf (data
, allocatable
);
655 conf (value
, pointer
)
656 conf (value
, allocatable
)
657 conf (value
, subroutine
)
658 conf (value
, function
)
659 conf (value
, volatile_
)
660 conf (value
, dimension
)
661 conf (value
, codimension
)
662 conf (value
, external
)
664 conf (codimension
, result
)
667 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
670 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
674 conf (is_protected
, intrinsic
)
675 conf (is_protected
, in_common
)
677 conf (asynchronous
, intrinsic
)
678 conf (asynchronous
, external
)
680 conf (volatile_
, intrinsic
)
681 conf (volatile_
, external
)
683 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
690 conf (procedure
, allocatable
)
691 conf (procedure
, dimension
)
692 conf (procedure
, codimension
)
693 conf (procedure
, intrinsic
)
694 conf (procedure
, target
)
695 conf (procedure
, value
)
696 conf (procedure
, volatile_
)
697 conf (procedure
, asynchronous
)
698 conf (procedure
, entry
)
700 conf (proc_pointer
, abstract
)
701 conf (proc_pointer
, omp_declare_target
)
702 conf (proc_pointer
, omp_declare_target_link
)
704 conf (entry
, omp_declare_target
)
705 conf (entry
, omp_declare_target_link
)
706 conf (entry
, oacc_declare_create
)
707 conf (entry
, oacc_declare_copyin
)
708 conf (entry
, oacc_declare_deviceptr
)
709 conf (entry
, oacc_declare_device_resident
)
711 conf (pdt_kind
, allocatable
)
712 conf (pdt_kind
, pointer
)
713 conf (pdt_kind
, dimension
)
714 conf (pdt_kind
, codimension
)
716 conf (pdt_len
, allocatable
)
717 conf (pdt_len
, pointer
)
718 conf (pdt_len
, dimension
)
719 conf (pdt_len
, codimension
)
721 if (attr
->access
== ACCESS_PRIVATE
)
728 a1
= gfc_code2string (flavors
, attr
->flavor
);
730 if (attr
->in_namelist
731 && attr
->flavor
!= FL_VARIABLE
732 && attr
->flavor
!= FL_PROCEDURE
733 && attr
->flavor
!= FL_UNKNOWN
)
739 switch (attr
->flavor
)
749 conf2 (asynchronous
);
752 conf2 (is_protected
);
762 conf2 (threadprivate
);
763 conf2 (omp_declare_target
);
764 conf2 (omp_declare_target_link
);
765 conf2 (oacc_declare_create
);
766 conf2 (oacc_declare_copyin
);
767 conf2 (oacc_declare_deviceptr
);
768 conf2 (oacc_declare_device_resident
);
770 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
772 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
773 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
780 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
794 /* Conflicts with INTENT, SAVE and RESULT will be checked
795 at resolution stage, see "resolve_fl_procedure". */
797 if (attr
->subroutine
)
803 conf2 (asynchronous
);
808 if (!attr
->proc_pointer
)
809 conf2 (threadprivate
);
812 /* Procedure pointers in COMMON blocks are allowed in F03,
813 * but forbidden per F08:C5100. */
814 if (!attr
->proc_pointer
|| (gfc_option
.allow_std
& GFC_STD_F2008
))
817 conf2 (omp_declare_target_link
);
821 case PROC_ST_FUNCTION
:
832 conf2 (threadprivate
);
852 conf2 (threadprivate
);
854 conf2 (omp_declare_target
);
855 conf2 (omp_declare_target_link
);
856 conf2 (oacc_declare_create
);
857 conf2 (oacc_declare_copyin
);
858 conf2 (oacc_declare_deviceptr
);
859 conf2 (oacc_declare_device_resident
);
861 if (attr
->intent
!= INTENT_UNKNOWN
)
878 conf2 (is_protected
);
884 conf2 (asynchronous
);
885 conf2 (threadprivate
);
901 gfc_error ("%s attribute conflicts with %s attribute at %L",
904 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
905 a1
, a2
, name
, where
);
912 return gfc_notify_std (standard
, "%s attribute conflicts "
913 "with %s attribute at %L", a1
, a2
,
918 return gfc_notify_std (standard
, "%s attribute conflicts "
919 "with %s attribute in %qs at %L",
920 a1
, a2
, name
, where
);
929 /* Mark a symbol as referenced. */
932 gfc_set_sym_referenced (gfc_symbol
*sym
)
935 if (sym
->attr
.referenced
)
938 sym
->attr
.referenced
= 1;
940 /* Remember which order dummy variables are accessed in. */
942 sym
->dummy_order
= next_dummy_order
++;
946 /* Common subroutine called by attribute changing subroutines in order
947 to prevent them from changing a symbol that has been
948 use-associated. Returns zero if it is OK to change the symbol,
952 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
955 if (attr
->use_assoc
== 0)
959 where
= &gfc_current_locus
;
962 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
965 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
972 /* Generate an error because of a duplicate attribute. */
975 duplicate_attr (const char *attr
, locus
*where
)
979 where
= &gfc_current_locus
;
981 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
986 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
987 locus
*where ATTRIBUTE_UNUSED
)
989 attr
->ext_attr
|= 1 << ext_attr
;
994 /* Called from decl.c (attr_decl1) to check attributes, when declared
998 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
1000 if (check_used (attr
, NULL
, where
))
1003 return check_conflict (attr
, NULL
, where
);
1008 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
1011 if (check_used (attr
, NULL
, where
))
1014 if (attr
->allocatable
)
1016 duplicate_attr ("ALLOCATABLE", where
);
1020 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1021 && !gfc_find_state (COMP_INTERFACE
))
1023 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1028 attr
->allocatable
= 1;
1029 return check_conflict (attr
, NULL
, where
);
1034 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1036 if (check_used (attr
, name
, where
))
1039 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
1040 "Duplicate AUTOMATIC attribute specified at %L", where
))
1043 attr
->automatic
= 1;
1044 return check_conflict (attr
, name
, where
);
1049 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1052 if (check_used (attr
, name
, where
))
1055 if (attr
->codimension
)
1057 duplicate_attr ("CODIMENSION", where
);
1061 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1062 && !gfc_find_state (COMP_INTERFACE
))
1064 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1065 "at %L", name
, where
);
1069 attr
->codimension
= 1;
1070 return check_conflict (attr
, name
, where
);
1075 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1078 if (check_used (attr
, name
, where
))
1081 if (attr
->dimension
)
1083 duplicate_attr ("DIMENSION", where
);
1087 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1088 && !gfc_find_state (COMP_INTERFACE
))
1090 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1091 "at %L", name
, where
);
1095 attr
->dimension
= 1;
1096 return check_conflict (attr
, name
, where
);
1101 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1104 if (check_used (attr
, name
, where
))
1107 attr
->contiguous
= 1;
1108 return check_conflict (attr
, name
, where
);
1113 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1116 if (check_used (attr
, NULL
, where
))
1121 duplicate_attr ("EXTERNAL", where
);
1125 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1128 attr
->proc_pointer
= 1;
1133 return check_conflict (attr
, NULL
, where
);
1138 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1141 if (check_used (attr
, NULL
, where
))
1144 if (attr
->intrinsic
)
1146 duplicate_attr ("INTRINSIC", where
);
1150 attr
->intrinsic
= 1;
1152 return check_conflict (attr
, NULL
, where
);
1157 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1160 if (check_used (attr
, NULL
, where
))
1165 duplicate_attr ("OPTIONAL", where
);
1170 return check_conflict (attr
, NULL
, where
);
1174 gfc_add_kind (symbol_attribute
*attr
, locus
*where
)
1178 duplicate_attr ("KIND", where
);
1183 return check_conflict (attr
, NULL
, where
);
1187 gfc_add_len (symbol_attribute
*attr
, locus
*where
)
1191 duplicate_attr ("LEN", where
);
1196 return check_conflict (attr
, NULL
, where
);
1201 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1204 if (check_used (attr
, NULL
, where
))
1207 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1208 && !gfc_find_state (COMP_INTERFACE
)))
1210 duplicate_attr ("POINTER", where
);
1214 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1215 || (attr
->if_source
== IFSRC_IFBODY
1216 && !gfc_find_state (COMP_INTERFACE
)))
1217 attr
->proc_pointer
= 1;
1221 return check_conflict (attr
, NULL
, where
);
1226 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1229 if (check_used (attr
, NULL
, where
))
1232 attr
->cray_pointer
= 1;
1233 return check_conflict (attr
, NULL
, where
);
1238 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1241 if (check_used (attr
, NULL
, where
))
1244 if (attr
->cray_pointee
)
1246 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1247 " statements", where
);
1251 attr
->cray_pointee
= 1;
1252 return check_conflict (attr
, NULL
, where
);
1257 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1259 if (check_used (attr
, name
, where
))
1262 if (attr
->is_protected
)
1264 if (!gfc_notify_std (GFC_STD_LEGACY
,
1265 "Duplicate PROTECTED attribute specified at %L",
1270 attr
->is_protected
= 1;
1271 return check_conflict (attr
, name
, where
);
1276 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1279 if (check_used (attr
, name
, where
))
1283 return check_conflict (attr
, name
, where
);
1288 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1292 if (check_used (attr
, name
, where
))
1295 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1298 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1303 if (s
== SAVE_EXPLICIT
)
1304 gfc_unset_implicit_pure (NULL
);
1306 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1308 if (!gfc_notify_std (GFC_STD_LEGACY
,
1309 "Duplicate SAVE attribute specified at %L",
1315 return check_conflict (attr
, name
, where
);
1320 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1323 if (check_used (attr
, name
, where
))
1328 if (!gfc_notify_std (GFC_STD_LEGACY
,
1329 "Duplicate VALUE attribute specified at %L",
1335 return check_conflict (attr
, name
, where
);
1340 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1342 /* No check_used needed as 11.2.1 of the F2003 standard allows
1343 that the local identifier made accessible by a use statement can be
1344 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1346 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1347 if (!gfc_notify_std (GFC_STD_LEGACY
,
1348 "Duplicate VOLATILE attribute specified at %L",
1352 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1353 shall not appear in a pure subprogram.
1355 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1356 construct within a pure subprogram, shall not have the SAVE or
1357 VOLATILE attribute. */
1358 if (gfc_pure (NULL
))
1360 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1361 "PURE procedure", where
);
1366 attr
->volatile_
= 1;
1367 attr
->volatile_ns
= gfc_current_ns
;
1368 return check_conflict (attr
, name
, where
);
1373 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1375 /* No check_used needed as 11.2.1 of the F2003 standard allows
1376 that the local identifier made accessible by a use statement can be
1377 given a ASYNCHRONOUS attribute. */
1379 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1380 if (!gfc_notify_std (GFC_STD_LEGACY
,
1381 "Duplicate ASYNCHRONOUS attribute specified at %L",
1385 attr
->asynchronous
= 1;
1386 attr
->asynchronous_ns
= gfc_current_ns
;
1387 return check_conflict (attr
, name
, where
);
1392 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1395 if (check_used (attr
, name
, where
))
1398 if (attr
->threadprivate
)
1400 duplicate_attr ("THREADPRIVATE", where
);
1404 attr
->threadprivate
= 1;
1405 return check_conflict (attr
, name
, where
);
1410 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1414 if (check_used (attr
, name
, where
))
1417 if (attr
->omp_declare_target
)
1420 attr
->omp_declare_target
= 1;
1421 return check_conflict (attr
, name
, where
);
1426 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1430 if (check_used (attr
, name
, where
))
1433 if (attr
->omp_declare_target_link
)
1436 attr
->omp_declare_target_link
= 1;
1437 return check_conflict (attr
, name
, where
);
1442 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1445 if (check_used (attr
, name
, where
))
1448 if (attr
->oacc_declare_create
)
1451 attr
->oacc_declare_create
= 1;
1452 return check_conflict (attr
, name
, where
);
1457 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1460 if (check_used (attr
, name
, where
))
1463 if (attr
->oacc_declare_copyin
)
1466 attr
->oacc_declare_copyin
= 1;
1467 return check_conflict (attr
, name
, where
);
1472 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1475 if (check_used (attr
, name
, where
))
1478 if (attr
->oacc_declare_deviceptr
)
1481 attr
->oacc_declare_deviceptr
= 1;
1482 return check_conflict (attr
, name
, where
);
1487 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1490 if (check_used (attr
, name
, where
))
1493 if (attr
->oacc_declare_device_resident
)
1496 attr
->oacc_declare_device_resident
= 1;
1497 return check_conflict (attr
, name
, where
);
1502 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1505 if (check_used (attr
, NULL
, where
))
1510 duplicate_attr ("TARGET", where
);
1515 return check_conflict (attr
, NULL
, where
);
1520 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1523 if (check_used (attr
, name
, where
))
1526 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1528 return check_conflict (attr
, name
, where
);
1533 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1536 if (check_used (attr
, name
, where
))
1539 /* Duplicate attribute already checked for. */
1540 attr
->in_common
= 1;
1541 return check_conflict (attr
, name
, where
);
1546 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1549 /* Duplicate attribute already checked for. */
1550 attr
->in_equivalence
= 1;
1551 if (!check_conflict (attr
, name
, where
))
1554 if (attr
->flavor
== FL_VARIABLE
)
1557 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1562 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1565 if (check_used (attr
, name
, where
))
1569 return check_conflict (attr
, name
, where
);
1574 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1577 attr
->in_namelist
= 1;
1578 return check_conflict (attr
, name
, where
);
1583 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1586 if (check_used (attr
, name
, where
))
1590 return check_conflict (attr
, name
, where
);
1595 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1598 if (check_used (attr
, NULL
, where
))
1601 if (attr
->elemental
)
1603 duplicate_attr ("ELEMENTAL", where
);
1607 attr
->elemental
= 1;
1608 return check_conflict (attr
, NULL
, where
);
1613 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1616 if (check_used (attr
, NULL
, where
))
1621 duplicate_attr ("PURE", where
);
1626 return check_conflict (attr
, NULL
, where
);
1631 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1634 if (check_used (attr
, NULL
, where
))
1637 if (attr
->recursive
)
1639 duplicate_attr ("RECURSIVE", where
);
1643 attr
->recursive
= 1;
1644 return check_conflict (attr
, NULL
, where
);
1649 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1652 if (check_used (attr
, name
, where
))
1657 duplicate_attr ("ENTRY", where
);
1662 return check_conflict (attr
, name
, where
);
1667 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1670 if (attr
->flavor
!= FL_PROCEDURE
1671 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1675 return check_conflict (attr
, name
, where
);
1680 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1683 if (attr
->flavor
!= FL_PROCEDURE
1684 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1687 attr
->subroutine
= 1;
1688 return check_conflict (attr
, name
, where
);
1693 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1696 if (attr
->flavor
!= FL_PROCEDURE
1697 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1701 return check_conflict (attr
, name
, where
);
1706 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1709 if (check_used (attr
, NULL
, where
))
1712 if (attr
->flavor
!= FL_PROCEDURE
1713 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1716 if (attr
->procedure
)
1718 duplicate_attr ("PROCEDURE", where
);
1722 attr
->procedure
= 1;
1724 return check_conflict (attr
, NULL
, where
);
1729 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1733 duplicate_attr ("ABSTRACT", where
);
1739 return check_conflict (attr
, NULL
, where
);
1743 /* Flavors are special because some flavors are not what Fortran
1744 considers attributes and can be reaffirmed multiple times. */
1747 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1751 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1752 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1753 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1756 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1759 /* Copying a procedure dummy argument for a module procedure in a
1760 submodule results in the flavor being copied and would result in
1761 an error without this. */
1762 if (gfc_new_block
&& gfc_new_block
->abr_modproc_decl
1763 && attr
->flavor
== f
&& f
== FL_PROCEDURE
)
1766 if (attr
->flavor
!= FL_UNKNOWN
)
1769 where
= &gfc_current_locus
;
1772 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1773 gfc_code2string (flavors
, attr
->flavor
), name
,
1774 gfc_code2string (flavors
, f
), where
);
1776 gfc_error ("%s attribute conflicts with %s attribute at %L",
1777 gfc_code2string (flavors
, attr
->flavor
),
1778 gfc_code2string (flavors
, f
), where
);
1785 return check_conflict (attr
, name
, where
);
1790 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1791 const char *name
, locus
*where
)
1794 if (check_used (attr
, name
, where
))
1797 if (attr
->flavor
!= FL_PROCEDURE
1798 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1802 where
= &gfc_current_locus
;
1804 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
)
1806 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1807 && !gfc_notification_std (GFC_STD_F2008
))
1808 gfc_error ("%s procedure at %L is already declared as %s "
1809 "procedure. \nF2008: A pointer function assignment "
1810 "is ambiguous if it is the first executable statement "
1811 "after the specification block. Please add any other "
1812 "kind of executable statement before it. FIXME",
1813 gfc_code2string (procedures
, t
), where
,
1814 gfc_code2string (procedures
, attr
->proc
));
1816 gfc_error ("%s procedure at %L is already declared as %s "
1817 "procedure", gfc_code2string (procedures
, t
), where
,
1818 gfc_code2string (procedures
, attr
->proc
));
1825 /* Statement functions are always scalar and functions. */
1826 if (t
== PROC_ST_FUNCTION
1827 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1828 || attr
->dimension
))
1831 return check_conflict (attr
, name
, where
);
1836 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1839 if (check_used (attr
, NULL
, where
))
1842 if (attr
->intent
== INTENT_UNKNOWN
)
1844 attr
->intent
= intent
;
1845 return check_conflict (attr
, NULL
, where
);
1849 where
= &gfc_current_locus
;
1851 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1852 gfc_intent_string (attr
->intent
),
1853 gfc_intent_string (intent
), where
);
1859 /* No checks for use-association in public and private statements. */
1862 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1863 const char *name
, locus
*where
)
1866 if (attr
->access
== ACCESS_UNKNOWN
1867 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1869 attr
->access
= access
;
1870 return check_conflict (attr
, name
, where
);
1874 where
= &gfc_current_locus
;
1875 gfc_error ("ACCESS specification at %L was already specified", where
);
1881 /* Set the is_bind_c field for the given symbol_attribute. */
1884 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1885 int is_proc_lang_bind_spec
)
1888 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1889 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1890 "variables or common blocks", where
);
1891 else if (attr
->is_bind_c
)
1892 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1894 attr
->is_bind_c
= 1;
1897 where
= &gfc_current_locus
;
1899 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1902 return check_conflict (attr
, name
, where
);
1906 /* Set the extension field for the given symbol_attribute. */
1909 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1912 where
= &gfc_current_locus
;
1914 if (attr
->extension
)
1915 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1917 attr
->extension
= 1;
1919 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1927 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1928 gfc_formal_arglist
* formal
, locus
*where
)
1930 if (check_used (&sym
->attr
, sym
->name
, where
))
1933 /* Skip the following checks in the case of a module_procedures in a
1934 submodule since they will manifestly fail. */
1935 if (sym
->attr
.module_procedure
== 1
1936 && source
== IFSRC_DECL
)
1940 where
= &gfc_current_locus
;
1942 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1943 && sym
->attr
.if_source
!= IFSRC_DECL
)
1945 gfc_error ("Symbol %qs at %L already has an explicit interface",
1950 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1952 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1953 "body", sym
->name
, where
);
1958 sym
->formal
= formal
;
1959 sym
->attr
.if_source
= source
;
1965 /* Add a type to a symbol. */
1968 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1974 where
= &gfc_current_locus
;
1977 type
= sym
->result
->ts
.type
;
1979 type
= sym
->ts
.type
;
1981 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1982 type
= sym
->ns
->proc_name
->ts
.type
;
1984 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1985 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1986 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
1987 && !sym
->attr
.module_procedure
)
1989 if (sym
->attr
.use_assoc
)
1990 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
1991 "use-associated at %L", sym
->name
, where
, sym
->module
,
1994 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
1995 where
, gfc_basic_typename (type
));
1999 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
2001 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2002 sym
->name
, where
, gfc_basic_typename (ts
->type
));
2006 flavor
= sym
->attr
.flavor
;
2008 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
2009 || flavor
== FL_LABEL
2010 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
2011 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
2013 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
2022 /* Clears all attributes. */
2025 gfc_clear_attr (symbol_attribute
*attr
)
2027 memset (attr
, 0, sizeof (symbol_attribute
));
2031 /* Check for missing attributes in the new symbol. Currently does
2032 nothing, but it's not clear that it is unnecessary yet. */
2035 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2036 locus
*where ATTRIBUTE_UNUSED
)
2043 /* Copy an attribute to a symbol attribute, bit by bit. Some
2044 attributes have a lot of side-effects but cannot be present given
2045 where we are called from, so we ignore some bits. */
2048 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2050 int is_proc_lang_bind_spec
;
2052 /* In line with the other attributes, we only add bits but do not remove
2053 them; cf. also PR 41034. */
2054 dest
->ext_attr
|= src
->ext_attr
;
2056 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2059 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2061 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2063 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2065 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2067 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2069 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2071 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2073 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2075 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2077 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2079 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2081 if (src
->threadprivate
2082 && !gfc_add_threadprivate (dest
, NULL
, where
))
2084 if (src
->omp_declare_target
2085 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2087 if (src
->omp_declare_target_link
2088 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2090 if (src
->oacc_declare_create
2091 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2093 if (src
->oacc_declare_copyin
2094 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2096 if (src
->oacc_declare_deviceptr
2097 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2099 if (src
->oacc_declare_device_resident
2100 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2102 if (src
->target
&& !gfc_add_target (dest
, where
))
2104 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2106 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2111 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2114 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2117 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2119 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2121 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2124 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2126 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2128 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2130 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2133 if (src
->flavor
!= FL_UNKNOWN
2134 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2137 if (src
->intent
!= INTENT_UNKNOWN
2138 && !gfc_add_intent (dest
, src
->intent
, where
))
2141 if (src
->access
!= ACCESS_UNKNOWN
2142 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2145 if (!gfc_missing_attr (dest
, where
))
2148 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2150 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2153 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2155 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2158 if (src
->is_c_interop
)
2159 dest
->is_c_interop
= 1;
2163 if (src
->external
&& !gfc_add_external (dest
, where
))
2165 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2167 if (src
->proc_pointer
)
2168 dest
->proc_pointer
= 1;
2177 /* A function to generate a dummy argument symbol using that from the
2178 interface declaration. Can be used for the result symbol as well if
2182 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2186 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2190 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2193 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2194 &gfc_current_locus
))
2197 if ((*dsym
)->attr
.dimension
)
2198 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2200 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2202 if ((*dsym
) != NULL
&& !result
2203 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2204 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2206 else if ((*dsym
) != NULL
&& result
2207 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2208 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2215 /************** Component name management ************/
2217 /* Component names of a derived type form their own little namespaces
2218 that are separate from all other spaces. The space is composed of
2219 a singly linked list of gfc_component structures whose head is
2220 located in the parent symbol. */
2223 /* Add a component name to a symbol. The call fails if the name is
2224 already present. On success, the component pointer is modified to
2225 point to the additional component structure. */
2228 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2229 gfc_component
**component
)
2231 gfc_component
*p
, *tail
;
2233 /* Check for existing components with the same name, but not for union
2234 components or containers. Unions and maps are anonymous so they have
2235 unique internal names which will never conflict.
2236 Don't use gfc_find_component here because it calls gfc_use_derived,
2237 but the derived type may not be fully defined yet. */
2240 for (p
= sym
->components
; p
; p
= p
->next
)
2242 if (strcmp (p
->name
, name
) == 0)
2244 gfc_error ("Component %qs at %C already declared at %L",
2252 if (sym
->attr
.extension
2253 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2254 name
, true, true, NULL
))
2256 gfc_error ("Component %qs at %C already in the parent type "
2257 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2261 /* Allocate a new component. */
2262 p
= gfc_get_component ();
2265 sym
->components
= p
;
2269 p
->name
= gfc_get_string ("%s", name
);
2270 p
->loc
= gfc_current_locus
;
2271 p
->ts
.type
= BT_UNKNOWN
;
2278 /* Recursive function to switch derived types of all symbol in a
2282 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2290 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2291 sym
->ts
.u
.derived
= to
;
2293 switch_types (st
->left
, from
, to
);
2294 switch_types (st
->right
, from
, to
);
2298 /* This subroutine is called when a derived type is used in order to
2299 make the final determination about which version to use. The
2300 standard requires that a type be defined before it is 'used', but
2301 such types can appear in IMPLICIT statements before the actual
2302 definition. 'Using' in this context means declaring a variable to
2303 be that type or using the type constructor.
2305 If a type is used and the components haven't been defined, then we
2306 have to have a derived type in a parent unit. We find the node in
2307 the other namespace and point the symtree node in this namespace to
2308 that node. Further reference to this name point to the correct
2309 node. If we can't find the node in a parent namespace, then we have
2312 This subroutine takes a pointer to a symbol node and returns a
2313 pointer to the translated node or NULL for an error. Usually there
2314 is no translation and we return the node we were passed. */
2317 gfc_use_derived (gfc_symbol
*sym
)
2327 if (sym
->attr
.unlimited_polymorphic
)
2330 if (sym
->attr
.generic
)
2331 sym
= gfc_find_dt_in_generic (sym
);
2333 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2334 return sym
; /* Already defined. */
2336 if (sym
->ns
->parent
== NULL
)
2339 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2341 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2345 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2348 /* Get rid of symbol sym, translating all references to s. */
2349 for (i
= 0; i
< GFC_LETTERS
; i
++)
2351 t
= &sym
->ns
->default_type
[i
];
2352 if (t
->u
.derived
== sym
)
2356 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2361 /* Unlink from list of modified symbols. */
2362 gfc_commit_symbol (sym
);
2364 switch_types (sym
->ns
->sym_root
, sym
, s
);
2366 /* TODO: Also have to replace sym -> s in other lists like
2367 namelists, common lists and interface lists. */
2368 gfc_free_symbol (sym
);
2373 gfc_error ("Derived type %qs at %C is being used before it is defined",
2379 /* Find the component with the given name in the union type symbol.
2380 If ref is not NULL it will be set to the chain of components through which
2381 the component can actually be accessed. This is necessary for unions because
2382 intermediate structures may be maps, nested structures, or other unions,
2383 all of which may (or must) be 'anonymous' to user code. */
2385 static gfc_component
*
2386 find_union_component (gfc_symbol
*un
, const char *name
,
2387 bool noaccess
, gfc_ref
**ref
)
2389 gfc_component
*m
, *check
;
2390 gfc_ref
*sref
, *tmp
;
2392 for (m
= un
->components
; m
; m
= m
->next
)
2394 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2398 /* Found component somewhere in m; chain the refs together. */
2402 sref
= gfc_get_ref ();
2403 sref
->type
= REF_COMPONENT
;
2404 sref
->u
.c
.component
= m
;
2405 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2410 /* Other checks (such as access) were done in the recursive calls. */
2417 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2418 the number of total candidates in CANDIDATES_LEN. */
2421 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2423 size_t &candidates_len
)
2425 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2426 vec_push (candidates
, candidates_len
, p
->name
);
2430 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2433 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2435 char **candidates
= NULL
;
2436 size_t candidates_len
= 0;
2437 lookup_component_fuzzy_find_candidates (component
, candidates
,
2439 return gfc_closest_fuzzy_match (member
, candidates
);
2443 /* Given a derived type node and a component name, try to locate the
2444 component structure. Returns the NULL pointer if the component is
2445 not found or the components are private. If noaccess is set, no access
2446 checks are done. If silent is set, an error will not be generated if
2447 the component cannot be found or accessed.
2449 If ref is not NULL, *ref is set to represent the chain of components
2450 required to get to the ultimate component.
2452 If the component is simply a direct subcomponent, or is inherited from a
2453 parent derived type in the given derived type, this is a single ref with its
2454 component set to the returned component.
2456 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2457 when the component is found through an implicit chain of nested union and
2458 map components. Unions and maps are "anonymous" substructures in FORTRAN
2459 which cannot be explicitly referenced, but the reference chain must be
2460 considered as in C for backend translation to correctly compute layouts.
2461 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2464 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2465 bool noaccess
, bool silent
, gfc_ref
**ref
)
2467 gfc_component
*p
, *check
;
2468 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2470 if (name
== NULL
|| sym
== NULL
)
2473 if (sym
->attr
.flavor
== FL_DERIVED
)
2474 sym
= gfc_use_derived (sym
);
2476 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2481 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2482 if (sym
->attr
.flavor
== FL_UNION
)
2483 return find_union_component (sym
, name
, noaccess
, ref
);
2485 if (ref
) *ref
= NULL
;
2486 for (p
= sym
->components
; p
; p
= p
->next
)
2488 /* Nest search into union's maps. */
2489 if (p
->ts
.type
== BT_UNION
)
2491 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2497 sref
= gfc_get_ref ();
2498 sref
->type
= REF_COMPONENT
;
2499 sref
->u
.c
.component
= p
;
2500 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2507 else if (strcmp (p
->name
, name
) == 0)
2513 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2515 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2516 if (p
->attr
.access
== ACCESS_PRIVATE
||
2517 (p
->attr
.access
!= ACCESS_PUBLIC
2518 && sym
->component_access
== ACCESS_PRIVATE
2519 && !is_parent_comp
))
2522 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2529 && sym
->attr
.extension
2530 && sym
->components
->ts
.type
== BT_DERIVED
)
2532 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2533 noaccess
, silent
, ref
);
2534 /* Do not overwrite the error. */
2539 if (p
== NULL
&& !silent
)
2541 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2543 gfc_error ("%qs at %C is not a member of the %qs structure"
2544 "; did you mean %qs?",
2545 name
, sym
->name
, guessed
);
2547 gfc_error ("%qs at %C is not a member of the %qs structure",
2551 /* Component was found; build the ultimate component reference. */
2552 if (p
!= NULL
&& ref
)
2554 tmp
= gfc_get_ref ();
2555 tmp
->type
= REF_COMPONENT
;
2556 tmp
->u
.c
.component
= p
;
2558 /* Link the final component ref to the end of the chain of subrefs. */
2562 for (; sref
->next
; sref
= sref
->next
)
2574 /* Given a symbol, free all of the component structures and everything
2578 free_components (gfc_component
*p
)
2586 gfc_free_array_spec (p
->as
);
2587 gfc_free_expr (p
->initializer
);
2589 gfc_free_expr (p
->kind_expr
);
2591 gfc_free_actual_arglist (p
->param_list
);
2599 /******************** Statement label management ********************/
2601 /* Comparison function for statement labels, used for managing the
2605 compare_st_labels (void *a1
, void *b1
)
2607 int a
= ((gfc_st_label
*) a1
)->value
;
2608 int b
= ((gfc_st_label
*) b1
)->value
;
2614 /* Free a single gfc_st_label structure, making sure the tree is not
2615 messed up. This function is called only when some parse error
2619 gfc_free_st_label (gfc_st_label
*label
)
2625 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2627 if (label
->format
!= NULL
)
2628 gfc_free_expr (label
->format
);
2634 /* Free a whole tree of gfc_st_label structures. */
2637 free_st_labels (gfc_st_label
*label
)
2643 free_st_labels (label
->left
);
2644 free_st_labels (label
->right
);
2646 if (label
->format
!= NULL
)
2647 gfc_free_expr (label
->format
);
2652 /* Given a label number, search for and return a pointer to the label
2653 structure, creating it if it does not exist. */
2656 gfc_get_st_label (int labelno
)
2661 if (gfc_current_state () == COMP_DERIVED
)
2662 ns
= gfc_current_block ()->f2k_derived
;
2665 /* Find the namespace of the scoping unit:
2666 If we're in a BLOCK construct, jump to the parent namespace. */
2667 ns
= gfc_current_ns
;
2668 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2672 /* First see if the label is already in this namespace. */
2676 if (lp
->value
== labelno
)
2679 if (lp
->value
< labelno
)
2685 lp
= XCNEW (gfc_st_label
);
2687 lp
->value
= labelno
;
2688 lp
->defined
= ST_LABEL_UNKNOWN
;
2689 lp
->referenced
= ST_LABEL_UNKNOWN
;
2692 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2698 /* Called when a statement with a statement label is about to be
2699 accepted. We add the label to the list of the current namespace,
2700 making sure it hasn't been defined previously and referenced
2704 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2708 labelno
= lp
->value
;
2710 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2711 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2712 &lp
->where
, label_locus
);
2715 lp
->where
= *label_locus
;
2719 case ST_LABEL_FORMAT
:
2720 if (lp
->referenced
== ST_LABEL_TARGET
2721 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2722 gfc_error ("Label %d at %C already referenced as branch target",
2725 lp
->defined
= ST_LABEL_FORMAT
;
2729 case ST_LABEL_TARGET
:
2730 case ST_LABEL_DO_TARGET
:
2731 if (lp
->referenced
== ST_LABEL_FORMAT
)
2732 gfc_error ("Label %d at %C already referenced as a format label",
2737 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2738 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2739 "DO termination statement which is not END DO"
2740 " or CONTINUE with label %d at %C", labelno
))
2742 if (type
== ST_LABEL_DO_TARGET
2743 && !gfc_notify_std (GFC_STD_F2018_OBS
, "Labeled DO statement "
2744 "at %L", label_locus
))
2749 lp
->defined
= ST_LABEL_BAD_TARGET
;
2750 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2756 /* Reference a label. Given a label and its type, see if that
2757 reference is consistent with what is known about that label,
2758 updating the unknown state. Returns false if something goes
2762 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2764 gfc_sl_type label_type
;
2771 labelno
= lp
->value
;
2773 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2774 label_type
= lp
->defined
;
2777 label_type
= lp
->referenced
;
2778 lp
->where
= gfc_current_locus
;
2781 if (label_type
== ST_LABEL_FORMAT
2782 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2784 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2789 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2790 || label_type
== ST_LABEL_BAD_TARGET
)
2791 && type
== ST_LABEL_FORMAT
)
2793 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2798 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2799 && !gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
2800 "Shared DO termination label %d at %C", labelno
))
2803 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2804 lp
->referenced
= type
;
2812 /************** Symbol table management subroutines ****************/
2814 /* Basic details: Fortran 95 requires a potentially unlimited number
2815 of distinct namespaces when compiling a program unit. This case
2816 occurs during a compilation of internal subprograms because all of
2817 the internal subprograms must be read before we can start
2818 generating code for the host.
2820 Given the tricky nature of the Fortran grammar, we must be able to
2821 undo changes made to a symbol table if the current interpretation
2822 of a statement is found to be incorrect. Whenever a symbol is
2823 looked up, we make a copy of it and link to it. All of these
2824 symbols are kept in a vector so that we can commit or
2825 undo the changes at a later time.
2827 A symtree may point to a symbol node outside of its namespace. In
2828 this case, that symbol has been used as a host associated variable
2829 at some previous time. */
2831 /* Allocate a new namespace structure. Copies the implicit types from
2832 PARENT if PARENT_TYPES is set. */
2835 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2842 ns
= XCNEW (gfc_namespace
);
2843 ns
->sym_root
= NULL
;
2844 ns
->uop_root
= NULL
;
2845 ns
->tb_sym_root
= NULL
;
2846 ns
->finalizers
= NULL
;
2847 ns
->default_access
= ACCESS_UNKNOWN
;
2848 ns
->parent
= parent
;
2850 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2852 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2853 ns
->tb_op
[in
] = NULL
;
2856 /* Initialize default implicit types. */
2857 for (i
= 'a'; i
<= 'z'; i
++)
2859 ns
->set_flag
[i
- 'a'] = 0;
2860 ts
= &ns
->default_type
[i
- 'a'];
2862 if (parent_types
&& ns
->parent
!= NULL
)
2864 /* Copy parent settings. */
2865 *ts
= ns
->parent
->default_type
[i
- 'a'];
2869 if (flag_implicit_none
!= 0)
2875 if ('i' <= i
&& i
<= 'n')
2877 ts
->type
= BT_INTEGER
;
2878 ts
->kind
= gfc_default_integer_kind
;
2883 ts
->kind
= gfc_default_real_kind
;
2887 if (parent_types
&& ns
->parent
!= NULL
)
2888 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2896 /* Comparison function for symtree nodes. */
2899 compare_symtree (void *_st1
, void *_st2
)
2901 gfc_symtree
*st1
, *st2
;
2903 st1
= (gfc_symtree
*) _st1
;
2904 st2
= (gfc_symtree
*) _st2
;
2906 return strcmp (st1
->name
, st2
->name
);
2910 /* Allocate a new symtree node and associate it with the new symbol. */
2913 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2917 st
= XCNEW (gfc_symtree
);
2918 st
->name
= gfc_get_string ("%s", name
);
2920 gfc_insert_bbt (root
, st
, compare_symtree
);
2925 /* Delete a symbol from the tree. Does not free the symbol itself! */
2928 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2930 gfc_symtree st
, *st0
;
2933 /* Submodules are marked as mod.submod. When freeing a submodule
2934 symbol, the symtree only has "submod", so adjust that here. */
2936 p
= strrchr(name
, '.');
2942 st0
= gfc_find_symtree (*root
, p
);
2944 st
.name
= gfc_get_string ("%s", p
);
2945 gfc_delete_bbt (root
, &st
, compare_symtree
);
2951 /* Given a root symtree node and a name, try to find the symbol within
2952 the namespace. Returns NULL if the symbol is not found. */
2955 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2961 c
= strcmp (name
, st
->name
);
2965 st
= (c
< 0) ? st
->left
: st
->right
;
2972 /* Return a symtree node with a name that is guaranteed to be unique
2973 within the namespace and corresponds to an illegal fortran name. */
2976 gfc_get_unique_symtree (gfc_namespace
*ns
)
2978 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2979 static int serial
= 0;
2981 sprintf (name
, "@%d", serial
++);
2982 return gfc_new_symtree (&ns
->sym_root
, name
);
2986 /* Given a name find a user operator node, creating it if it doesn't
2987 exist. These are much simpler than symbols because they can't be
2988 ambiguous with one another. */
2991 gfc_get_uop (const char *name
)
2995 gfc_namespace
*ns
= gfc_current_ns
;
2999 st
= gfc_find_symtree (ns
->uop_root
, name
);
3003 st
= gfc_new_symtree (&ns
->uop_root
, name
);
3005 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
3006 uop
->name
= gfc_get_string ("%s", name
);
3007 uop
->access
= ACCESS_UNKNOWN
;
3014 /* Given a name find the user operator node. Returns NULL if it does
3018 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3023 ns
= gfc_current_ns
;
3025 st
= gfc_find_symtree (ns
->uop_root
, name
);
3026 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3030 /* Update a symbol's common_block field, and take care of the associated
3031 memory management. */
3034 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3036 if (sym
->common_block
== common_block
)
3039 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3041 sym
->common_block
->refs
--;
3042 if (sym
->common_block
->refs
== 0)
3043 free (sym
->common_block
);
3045 sym
->common_block
= common_block
;
3049 /* Remove a gfc_symbol structure and everything it points to. */
3052 gfc_free_symbol (gfc_symbol
*sym
)
3058 gfc_free_array_spec (sym
->as
);
3060 free_components (sym
->components
);
3062 gfc_free_expr (sym
->value
);
3064 gfc_free_namelist (sym
->namelist
);
3066 if (sym
->ns
!= sym
->formal_ns
)
3067 gfc_free_namespace (sym
->formal_ns
);
3069 if (!sym
->attr
.generic_copy
)
3070 gfc_free_interface (sym
->generic
);
3072 gfc_free_formal_arglist (sym
->formal
);
3074 gfc_free_namespace (sym
->f2k_derived
);
3076 set_symbol_common_block (sym
, NULL
);
3078 if (sym
->param_list
)
3079 gfc_free_actual_arglist (sym
->param_list
);
3085 /* Decrease the reference counter and free memory when we reach zero. */
3088 gfc_release_symbol (gfc_symbol
*sym
)
3093 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
3094 && (!sym
->attr
.entry
|| !sym
->module
))
3096 /* As formal_ns contains a reference to sym, delete formal_ns just
3097 before the deletion of sym. */
3098 gfc_namespace
*ns
= sym
->formal_ns
;
3099 sym
->formal_ns
= NULL
;
3100 gfc_free_namespace (ns
);
3107 gcc_assert (sym
->refs
== 0);
3108 gfc_free_symbol (sym
);
3112 /* Allocate and initialize a new symbol node. */
3115 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3119 p
= XCNEW (gfc_symbol
);
3121 gfc_clear_ts (&p
->ts
);
3122 gfc_clear_attr (&p
->attr
);
3125 p
->declared_at
= gfc_current_locus
;
3127 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
3128 gfc_internal_error ("new_symbol(): Symbol name too long");
3130 p
->name
= gfc_get_string ("%s", name
);
3132 /* Make sure flags for symbol being C bound are clear initially. */
3133 p
->attr
.is_bind_c
= 0;
3134 p
->attr
.is_iso_c
= 0;
3136 /* Clear the ptrs we may need. */
3137 p
->common_block
= NULL
;
3138 p
->f2k_derived
= NULL
;
3140 p
->fn_result_spec
= 0;
3146 /* Generate an error if a symbol is ambiguous. */
3149 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3152 if (st
->n
.sym
->module
)
3153 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3154 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3156 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3157 "from current program unit", name
, st
->n
.sym
->name
);
3161 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3162 selector on the stack. If yes, replace it by the corresponding temporary. */
3165 select_type_insert_tmp (gfc_symtree
**st
)
3167 gfc_select_type_stack
*stack
= select_type_stack
;
3168 for (; stack
; stack
= stack
->prev
)
3169 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3172 select_type_insert_tmp (st
);
3178 /* Look for a symtree in the current procedure -- that is, go up to
3179 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3182 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3186 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3190 if (!ns
->construct_entities
)
3199 /* Search for a symtree starting in the current namespace, resorting to
3200 any parent namespaces if requested by a nonzero parent_flag.
3201 Returns nonzero if the name is ambiguous. */
3204 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3205 gfc_symtree
**result
)
3210 ns
= gfc_current_ns
;
3214 st
= gfc_find_symtree (ns
->sym_root
, name
);
3217 select_type_insert_tmp (&st
);
3220 /* Ambiguous generic interfaces are permitted, as long
3221 as the specific interfaces are different. */
3222 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3224 ambiguous_symbol (name
, st
);
3234 /* Don't escape an interface block. */
3235 if (ns
&& !ns
->has_import_set
3236 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3243 if (gfc_current_state() == COMP_DERIVED
3244 && gfc_current_block ()->attr
.pdt_template
)
3246 gfc_symbol
*der
= gfc_current_block ();
3247 for (; der
; der
= gfc_get_derived_super_type (der
))
3249 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3251 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3266 /* Same, but returns the symbol instead. */
3269 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3270 gfc_symbol
**result
)
3275 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3280 *result
= st
->n
.sym
;
3286 /* Tells whether there is only one set of changes in the stack. */
3289 single_undo_checkpoint_p (void)
3291 if (latest_undo_chgset
== &default_undo_chgset_var
)
3293 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3298 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3303 /* Save symbol with the information necessary to back it out. */
3306 gfc_save_symbol_data (gfc_symbol
*sym
)
3311 if (!single_undo_checkpoint_p ())
3313 /* If there is more than one change set, look for the symbol in the
3314 current one. If it is found there, we can reuse it. */
3315 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3318 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3322 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3325 s
= XCNEW (gfc_symbol
);
3327 sym
->old_symbol
= s
;
3330 latest_undo_chgset
->syms
.safe_push (sym
);
3334 /* Given a name, find a symbol, or create it if it does not exist yet
3335 in the current namespace. If the symbol is found we make sure that
3338 The integer return code indicates
3340 1 The symbol name was ambiguous
3341 2 The name meant to be established was already host associated.
3343 So if the return value is nonzero, then an error was issued. */
3346 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3347 bool allow_subroutine
)
3352 /* This doesn't usually happen during resolution. */
3354 ns
= gfc_current_ns
;
3356 /* Try to find the symbol in ns. */
3357 st
= gfc_find_symtree (ns
->sym_root
, name
);
3359 if (st
== NULL
&& ns
->omp_udr_ns
)
3362 st
= gfc_find_symtree (ns
->sym_root
, name
);
3367 /* If not there, create a new symbol. */
3368 p
= gfc_new_symbol (name
, ns
);
3370 /* Add to the list of tentative symbols. */
3371 p
->old_symbol
= NULL
;
3374 latest_undo_chgset
->syms
.safe_push (p
);
3376 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3383 /* Make sure the existing symbol is OK. Ambiguous
3384 generic interfaces are permitted, as long as the
3385 specific interfaces are different. */
3386 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3388 ambiguous_symbol (name
, st
);
3393 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3394 && !(allow_subroutine
&& p
->attr
.subroutine
)
3395 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3396 && (ns
->has_import_set
|| p
->attr
.imported
)))
3398 /* Symbol is from another namespace. */
3399 gfc_error ("Symbol %qs at %C has already been host associated",
3406 /* Copy in case this symbol is changed. */
3407 gfc_save_symbol_data (p
);
3416 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3421 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3426 *result
= st
->n
.sym
;
3433 /* Subroutine that searches for a symbol, creating it if it doesn't
3434 exist, but tries to host-associate the symbol if possible. */
3437 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3442 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3446 gfc_save_symbol_data (st
->n
.sym
);
3451 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3461 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3466 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3471 i
= gfc_get_ha_sym_tree (name
, &st
);
3474 *result
= st
->n
.sym
;
3482 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3483 head->name as the common_root symtree's name might be mangled. */
3485 static gfc_symtree
*
3486 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3489 gfc_symtree
*result
;
3494 if (st
->n
.common
== head
)
3497 result
= find_common_symtree (st
->left
, head
);
3499 result
= find_common_symtree (st
->right
, head
);
3505 /* Restore previous state of symbol. Just copy simple stuff. */
3508 restore_old_symbol (gfc_symbol
*p
)
3513 old
= p
->old_symbol
;
3515 p
->ts
.type
= old
->ts
.type
;
3516 p
->ts
.kind
= old
->ts
.kind
;
3518 p
->attr
= old
->attr
;
3520 if (p
->value
!= old
->value
)
3522 gcc_checking_assert (old
->value
== NULL
);
3523 gfc_free_expr (p
->value
);
3527 if (p
->as
!= old
->as
)
3530 gfc_free_array_spec (p
->as
);
3534 p
->generic
= old
->generic
;
3535 p
->component_access
= old
->component_access
;
3537 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3539 gfc_free_namelist (p
->namelist
);
3544 if (p
->namelist_tail
!= old
->namelist_tail
)
3546 gfc_free_namelist (old
->namelist_tail
->next
);
3547 old
->namelist_tail
->next
= NULL
;
3551 p
->namelist_tail
= old
->namelist_tail
;
3553 if (p
->formal
!= old
->formal
)
3555 gfc_free_formal_arglist (p
->formal
);
3556 p
->formal
= old
->formal
;
3559 set_symbol_common_block (p
, old
->common_block
);
3560 p
->common_head
= old
->common_head
;
3562 p
->old_symbol
= old
->old_symbol
;
3567 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3568 the structure itself. */
3571 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3578 /* Given a change set pointer, free its target's contents and update it with
3579 the address of the previous change set. Note that only the contents are
3580 freed, not the target itself (the contents' container). It is not a problem
3581 as the latter will be a local variable usually. */
3584 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3586 free_undo_change_set_data (*cs
);
3591 static void free_old_symbol (gfc_symbol
*sym
);
3594 /* Merges the current change set into the previous one. The changes themselves
3595 are left untouched; only one checkpoint is forgotten. */
3598 gfc_drop_last_undo_checkpoint (void)
3603 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3605 /* No need to loop in this case. */
3606 if (s
->old_symbol
== NULL
)
3609 /* Remove the duplicate symbols. */
3610 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3613 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3615 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3616 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3617 shall contain from now on the backup symbol for S as it was
3618 at the checkpoint before. */
3619 if (s
->old_symbol
->gfc_new
)
3621 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3622 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3623 free_old_symbol (s
);
3626 restore_old_symbol (s
->old_symbol
);
3631 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3632 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3634 pop_undo_change_set (latest_undo_chgset
);
3638 /* Undoes all the changes made to symbols since the previous checkpoint.
3639 This subroutine is made simpler due to the fact that attributes are
3640 never removed once added. */
3643 gfc_restore_last_undo_checkpoint (void)
3648 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3650 /* Symbol in a common block was new. Or was old and just put in common */
3652 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3654 /* If the symbol was added to any common block, it
3655 needs to be removed to stop the resolver looking
3656 for a (possibly) dead symbol. */
3657 if (p
->common_block
->head
== p
&& !p
->common_next
)
3659 gfc_symtree st
, *st0
;
3660 st0
= find_common_symtree (p
->ns
->common_root
,
3664 st
.name
= st0
->name
;
3665 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3670 if (p
->common_block
->head
== p
)
3671 p
->common_block
->head
= p
->common_next
;
3674 gfc_symbol
*cparent
, *csym
;
3676 cparent
= p
->common_block
->head
;
3677 csym
= cparent
->common_next
;
3682 csym
= csym
->common_next
;
3685 gcc_assert(cparent
->common_next
== p
);
3686 cparent
->common_next
= csym
->common_next
;
3688 p
->common_next
= NULL
;
3692 /* The derived type is saved in the symtree with the first
3693 letter capitalized; the all lower-case version to the
3694 derived type contains its associated generic function. */
3695 if (gfc_fl_struct (p
->attr
.flavor
))
3696 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3698 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3700 gfc_release_symbol (p
);
3703 restore_old_symbol (p
);
3706 latest_undo_chgset
->syms
.truncate (0);
3707 latest_undo_chgset
->tbps
.truncate (0);
3709 if (!single_undo_checkpoint_p ())
3710 pop_undo_change_set (latest_undo_chgset
);
3714 /* Makes sure that there is only one set of changes; in other words we haven't
3715 forgotten to pair a call to gfc_new_checkpoint with a call to either
3716 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3719 enforce_single_undo_checkpoint (void)
3721 gcc_checking_assert (single_undo_checkpoint_p ());
3725 /* Undoes all the changes made to symbols in the current statement. */
3728 gfc_undo_symbols (void)
3730 enforce_single_undo_checkpoint ();
3731 gfc_restore_last_undo_checkpoint ();
3735 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3736 components of old_symbol that might need deallocation are the "allocatables"
3737 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3738 namelist_tail. In case these differ between old_symbol and sym, it's just
3739 because sym->namelist has gotten a few more items. */
3742 free_old_symbol (gfc_symbol
*sym
)
3745 if (sym
->old_symbol
== NULL
)
3748 if (sym
->old_symbol
->as
!= sym
->as
)
3749 gfc_free_array_spec (sym
->old_symbol
->as
);
3751 if (sym
->old_symbol
->value
!= sym
->value
)
3752 gfc_free_expr (sym
->old_symbol
->value
);
3754 if (sym
->old_symbol
->formal
!= sym
->formal
)
3755 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3757 free (sym
->old_symbol
);
3758 sym
->old_symbol
= NULL
;
3762 /* Makes the changes made in the current statement permanent-- gets
3763 rid of undo information. */
3766 gfc_commit_symbols (void)
3769 gfc_typebound_proc
*tbp
;
3772 enforce_single_undo_checkpoint ();
3774 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3778 free_old_symbol (p
);
3780 latest_undo_chgset
->syms
.truncate (0);
3782 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3784 latest_undo_chgset
->tbps
.truncate (0);
3788 /* Makes the changes made in one symbol permanent -- gets rid of undo
3792 gfc_commit_symbol (gfc_symbol
*sym
)
3797 enforce_single_undo_checkpoint ();
3799 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3802 latest_undo_chgset
->syms
.unordered_remove (i
);
3809 free_old_symbol (sym
);
3813 /* Recursively free trees containing type-bound procedures. */
3816 free_tb_tree (gfc_symtree
*t
)
3821 free_tb_tree (t
->left
);
3822 free_tb_tree (t
->right
);
3824 /* TODO: Free type-bound procedure structs themselves; probably needs some
3825 sort of ref-counting mechanism. */
3831 /* Recursive function that deletes an entire tree and all the common
3832 head structures it points to. */
3835 free_common_tree (gfc_symtree
* common_tree
)
3837 if (common_tree
== NULL
)
3840 free_common_tree (common_tree
->left
);
3841 free_common_tree (common_tree
->right
);
3847 /* Recursive function that deletes an entire tree and all the common
3848 head structures it points to. */
3851 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3853 if (omp_udr_tree
== NULL
)
3856 free_omp_udr_tree (omp_udr_tree
->left
);
3857 free_omp_udr_tree (omp_udr_tree
->right
);
3859 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3860 free (omp_udr_tree
);
3864 /* Recursive function that deletes an entire tree and all the user
3865 operator nodes that it contains. */
3868 free_uop_tree (gfc_symtree
*uop_tree
)
3870 if (uop_tree
== NULL
)
3873 free_uop_tree (uop_tree
->left
);
3874 free_uop_tree (uop_tree
->right
);
3876 gfc_free_interface (uop_tree
->n
.uop
->op
);
3877 free (uop_tree
->n
.uop
);
3882 /* Recursive function that deletes an entire tree and all the symbols
3883 that it contains. */
3886 free_sym_tree (gfc_symtree
*sym_tree
)
3888 if (sym_tree
== NULL
)
3891 free_sym_tree (sym_tree
->left
);
3892 free_sym_tree (sym_tree
->right
);
3894 gfc_release_symbol (sym_tree
->n
.sym
);
3899 /* Free the derived type list. */
3902 gfc_free_dt_list (void)
3904 gfc_dt_list
*dt
, *n
;
3906 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3912 gfc_derived_types
= NULL
;
3916 /* Free the gfc_equiv_info's. */
3919 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3923 gfc_free_equiv_infos (s
->next
);
3928 /* Free the gfc_equiv_lists. */
3931 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3935 gfc_free_equiv_lists (l
->next
);
3936 gfc_free_equiv_infos (l
->equiv
);
3941 /* Free a finalizer procedure list. */
3944 gfc_free_finalizer (gfc_finalizer
* el
)
3948 gfc_release_symbol (el
->proc_sym
);
3954 gfc_free_finalizer_list (gfc_finalizer
* list
)
3958 gfc_finalizer
* current
= list
;
3960 gfc_free_finalizer (current
);
3965 /* Create a new gfc_charlen structure and add it to a namespace.
3966 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3969 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3973 cl
= gfc_get_charlen ();
3978 cl
->length
= gfc_copy_expr (old_cl
->length
);
3979 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3980 cl
->backend_decl
= old_cl
->backend_decl
;
3981 cl
->passed_length
= old_cl
->passed_length
;
3982 cl
->resolved
= old_cl
->resolved
;
3985 /* Put into namespace. */
3986 cl
->next
= ns
->cl_list
;
3993 /* Free the charlen list from cl to end (end is not freed).
3994 Free the whole list if end is NULL. */
3997 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
4001 for (; cl
!= end
; cl
= cl2
)
4006 gfc_free_expr (cl
->length
);
4012 /* Free entry list structs. */
4015 free_entry_list (gfc_entry_list
*el
)
4017 gfc_entry_list
*next
;
4024 free_entry_list (next
);
4028 /* Free a namespace structure and everything below it. Interface
4029 lists associated with intrinsic operators are not freed. These are
4030 taken care of when a specific name is freed. */
4033 gfc_free_namespace (gfc_namespace
*ns
)
4035 gfc_namespace
*p
, *q
;
4045 gcc_assert (ns
->refs
== 0);
4047 gfc_free_statements (ns
->code
);
4049 free_sym_tree (ns
->sym_root
);
4050 free_uop_tree (ns
->uop_root
);
4051 free_common_tree (ns
->common_root
);
4052 free_omp_udr_tree (ns
->omp_udr_root
);
4053 free_tb_tree (ns
->tb_sym_root
);
4054 free_tb_tree (ns
->tb_uop_root
);
4055 gfc_free_finalizer_list (ns
->finalizers
);
4056 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4057 gfc_free_charlen (ns
->cl_list
, NULL
);
4058 free_st_labels (ns
->st_labels
);
4060 free_entry_list (ns
->entries
);
4061 gfc_free_equiv (ns
->equiv
);
4062 gfc_free_equiv_lists (ns
->equiv_lists
);
4063 gfc_free_use_stmts (ns
->use_stmts
);
4065 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4066 gfc_free_interface (ns
->op
[i
]);
4068 gfc_free_data (ns
->data
);
4072 /* Recursively free any contained namespaces. */
4077 gfc_free_namespace (q
);
4083 gfc_symbol_init_2 (void)
4086 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4091 gfc_symbol_done_2 (void)
4093 if (gfc_current_ns
!= NULL
)
4095 /* free everything from the root. */
4096 while (gfc_current_ns
->parent
!= NULL
)
4097 gfc_current_ns
= gfc_current_ns
->parent
;
4098 gfc_free_namespace (gfc_current_ns
);
4099 gfc_current_ns
= NULL
;
4101 gfc_free_dt_list ();
4103 enforce_single_undo_checkpoint ();
4104 free_undo_change_set_data (*latest_undo_chgset
);
4108 /* Count how many nodes a symtree has. */
4111 count_st_nodes (const gfc_symtree
*st
)
4117 nodes
= count_st_nodes (st
->left
);
4119 nodes
+= count_st_nodes (st
->right
);
4125 /* Convert symtree tree into symtree vector. */
4128 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4133 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4134 st_vec
[node_cntr
++] = st
;
4135 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4141 /* Traverse namespace. As the functions might modify the symtree, we store the
4142 symtree as a vector and operate on this vector. Note: We assume that
4143 sym_func or st_func never deletes nodes from the symtree - only adding is
4144 allowed. Additionally, newly added nodes are not traversed. */
4147 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4148 void (*sym_func
) (gfc_symbol
*))
4150 gfc_symtree
**st_vec
;
4151 unsigned nodes
, i
, node_cntr
;
4153 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4154 nodes
= count_st_nodes (st
);
4155 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4157 fill_st_vector (st
, st_vec
, node_cntr
);
4162 for (i
= 0; i
< nodes
; i
++)
4163 st_vec
[i
]->n
.sym
->mark
= 0;
4164 for (i
= 0; i
< nodes
; i
++)
4165 if (!st_vec
[i
]->n
.sym
->mark
)
4167 (*sym_func
) (st_vec
[i
]->n
.sym
);
4168 st_vec
[i
]->n
.sym
->mark
= 1;
4172 for (i
= 0; i
< nodes
; i
++)
4173 (*st_func
) (st_vec
[i
]);
4177 /* Recursively traverse the symtree nodes. */
4180 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4182 do_traverse_symtree (st
, st_func
, NULL
);
4186 /* Call a given function for all symbols in the namespace. We take
4187 care that each gfc_symbol node is called exactly once. */
4190 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4192 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4196 /* Return TRUE when name is the name of an intrinsic type. */
4199 gfc_is_intrinsic_typename (const char *name
)
4201 if (strcmp (name
, "integer") == 0
4202 || strcmp (name
, "real") == 0
4203 || strcmp (name
, "character") == 0
4204 || strcmp (name
, "logical") == 0
4205 || strcmp (name
, "complex") == 0
4206 || strcmp (name
, "doubleprecision") == 0
4207 || strcmp (name
, "doublecomplex") == 0)
4214 /* Return TRUE if the symbol is an automatic variable. */
4217 gfc_is_var_automatic (gfc_symbol
*sym
)
4219 /* Pointer and allocatable variables are never automatic. */
4220 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4222 /* Check for arrays with non-constant size. */
4223 if (sym
->attr
.dimension
&& sym
->as
4224 && !gfc_is_compile_time_shape (sym
->as
))
4226 /* Check for non-constant length character variables. */
4227 if (sym
->ts
.type
== BT_CHARACTER
4229 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4231 /* Variables with explicit AUTOMATIC attribute. */
4232 if (sym
->attr
.automatic
)
4238 /* Given a symbol, mark it as SAVEd if it is allowed. */
4241 save_symbol (gfc_symbol
*sym
)
4244 if (sym
->attr
.use_assoc
)
4247 if (sym
->attr
.in_common
4250 || sym
->attr
.flavor
!= FL_VARIABLE
)
4252 /* Automatic objects are not saved. */
4253 if (gfc_is_var_automatic (sym
))
4255 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4259 /* Mark those symbols which can be SAVEd as such. */
4262 gfc_save_all (gfc_namespace
*ns
)
4264 gfc_traverse_ns (ns
, save_symbol
);
4268 /* Make sure that no changes to symbols are pending. */
4271 gfc_enforce_clean_symbol_state(void)
4273 enforce_single_undo_checkpoint ();
4274 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4278 /************** Global symbol handling ************/
4281 /* Search a tree for the global symbol. */
4284 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4293 c
= strcmp (name
, symbol
->name
);
4297 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4304 /* Case insensitive search a tree for the global symbol. */
4307 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4316 c
= strcasecmp (name
, symbol
->name
);
4320 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4327 /* Compare two global symbols. Used for managing the BB tree. */
4330 gsym_compare (void *_s1
, void *_s2
)
4332 gfc_gsymbol
*s1
, *s2
;
4334 s1
= (gfc_gsymbol
*) _s1
;
4335 s2
= (gfc_gsymbol
*) _s2
;
4336 return strcmp (s1
->name
, s2
->name
);
4340 /* Get a global symbol, creating it if it doesn't exist. */
4343 gfc_get_gsymbol (const char *name
)
4347 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4351 s
= XCNEW (gfc_gsymbol
);
4352 s
->type
= GSYM_UNKNOWN
;
4353 s
->name
= gfc_get_string ("%s", name
);
4355 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4362 get_iso_c_binding_dt (int sym_id
)
4364 gfc_dt_list
*dt_list
;
4366 dt_list
= gfc_derived_types
;
4368 /* Loop through the derived types in the name list, searching for
4369 the desired symbol from iso_c_binding. Search the parent namespaces
4370 if necessary and requested to (parent_flag). */
4371 while (dt_list
!= NULL
)
4373 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
4374 && dt_list
->derived
->intmod_sym_id
== sym_id
)
4375 return dt_list
->derived
;
4377 dt_list
= dt_list
->next
;
4384 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4385 with C. This is necessary for any derived type that is BIND(C) and for
4386 derived types that are parameters to functions that are BIND(C). All
4387 fields of the derived type are required to be interoperable, and are tested
4388 for such. If an error occurs, the errors are reported here, allowing for
4389 multiple errors to be handled for a single derived type. */
4392 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4394 gfc_component
*curr_comp
= NULL
;
4395 bool is_c_interop
= false;
4398 if (derived_sym
== NULL
)
4399 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4400 "unexpectedly NULL");
4402 /* If we've already looked at this derived symbol, do not look at it again
4403 so we don't repeat warnings/errors. */
4404 if (derived_sym
->ts
.is_c_interop
)
4407 /* The derived type must have the BIND attribute to be interoperable
4408 J3/04-007, Section 15.2.3. */
4409 if (derived_sym
->attr
.is_bind_c
!= 1)
4411 derived_sym
->ts
.is_c_interop
= 0;
4412 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4413 "attribute to be C interoperable", derived_sym
->name
,
4414 &(derived_sym
->declared_at
));
4418 curr_comp
= derived_sym
->components
;
4420 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4421 empty struct. Section 15.2 in Fortran 2003 states: "The following
4422 subclauses define the conditions under which a Fortran entity is
4423 interoperable. If a Fortran entity is interoperable, an equivalent
4424 entity may be defined by means of C and the Fortran entity is said
4425 to be interoperable with the C entity. There does not have to be such
4426 an interoperating C entity."
4428 if (curr_comp
== NULL
)
4430 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4431 "and may be inaccessible by the C companion processor",
4432 derived_sym
->name
, &(derived_sym
->declared_at
));
4433 derived_sym
->ts
.is_c_interop
= 1;
4434 derived_sym
->attr
.is_bind_c
= 1;
4439 /* Initialize the derived type as being C interoperable.
4440 If we find an error in the components, this will be set false. */
4441 derived_sym
->ts
.is_c_interop
= 1;
4443 /* Loop through the list of components to verify that the kind of
4444 each is a C interoperable type. */
4447 /* The components cannot be pointers (fortran sense).
4448 J3/04-007, Section 15.2.3, C1505. */
4449 if (curr_comp
->attr
.pointer
!= 0)
4451 gfc_error ("Component %qs at %L cannot have the "
4452 "POINTER attribute because it is a member "
4453 "of the BIND(C) derived type %qs at %L",
4454 curr_comp
->name
, &(curr_comp
->loc
),
4455 derived_sym
->name
, &(derived_sym
->declared_at
));
4459 if (curr_comp
->attr
.proc_pointer
!= 0)
4461 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4462 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4463 &curr_comp
->loc
, derived_sym
->name
,
4464 &derived_sym
->declared_at
);
4468 /* The components cannot be allocatable.
4469 J3/04-007, Section 15.2.3, C1505. */
4470 if (curr_comp
->attr
.allocatable
!= 0)
4472 gfc_error ("Component %qs at %L cannot have the "
4473 "ALLOCATABLE attribute because it is a member "
4474 "of the BIND(C) derived type %qs at %L",
4475 curr_comp
->name
, &(curr_comp
->loc
),
4476 derived_sym
->name
, &(derived_sym
->declared_at
));
4480 /* BIND(C) derived types must have interoperable components. */
4481 if (curr_comp
->ts
.type
== BT_DERIVED
4482 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4483 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4485 /* This should be allowed; the draft says a derived-type can not
4486 have type parameters if it is has the BIND attribute. Type
4487 parameters seem to be for making parameterized derived types.
4488 There's no need to verify the type if it is c_ptr/c_funptr. */
4489 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4493 /* Grab the typespec for the given component and test the kind. */
4494 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4498 /* Report warning and continue since not fatal. The
4499 draft does specify a constraint that requires all fields
4500 to interoperate, but if the user says real(4), etc., it
4501 may interoperate with *something* in C, but the compiler
4502 most likely won't know exactly what. Further, it may not
4503 interoperate with the same data type(s) in C if the user
4504 recompiles with different flags (e.g., -m32 and -m64 on
4505 x86_64 and using integer(4) to claim interop with a
4507 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4508 /* If the derived type is bind(c), all fields must be
4510 gfc_warning (OPT_Wc_binding_type
,
4511 "Component %qs in derived type %qs at %L "
4512 "may not be C interoperable, even though "
4513 "derived type %qs is BIND(C)",
4514 curr_comp
->name
, derived_sym
->name
,
4515 &(curr_comp
->loc
), derived_sym
->name
);
4516 else if (warn_c_binding_type
)
4517 /* If derived type is param to bind(c) routine, or to one
4518 of the iso_c_binding procs, it must be interoperable, so
4519 all fields must interop too. */
4520 gfc_warning (OPT_Wc_binding_type
,
4521 "Component %qs in derived type %qs at %L "
4522 "may not be C interoperable",
4523 curr_comp
->name
, derived_sym
->name
,
4528 curr_comp
= curr_comp
->next
;
4529 } while (curr_comp
!= NULL
);
4532 /* Make sure we don't have conflicts with the attributes. */
4533 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
4535 gfc_error ("Derived type %qs at %L cannot be declared with both "
4536 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
4537 &(derived_sym
->declared_at
));
4541 if (derived_sym
->attr
.sequence
!= 0)
4543 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4544 "attribute because it is BIND(C)", derived_sym
->name
,
4545 &(derived_sym
->declared_at
));
4549 /* Mark the derived type as not being C interoperable if we found an
4550 error. If there were only warnings, proceed with the assumption
4551 it's interoperable. */
4553 derived_sym
->ts
.is_c_interop
= 0;
4559 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4562 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4566 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4567 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4569 tmp_sym
->attr
.is_c_interop
= 1;
4570 tmp_sym
->attr
.is_bind_c
= 1;
4571 tmp_sym
->ts
.is_c_interop
= 1;
4572 tmp_sym
->ts
.is_iso_c
= 1;
4573 tmp_sym
->ts
.type
= BT_DERIVED
;
4574 tmp_sym
->ts
.f90_type
= BT_VOID
;
4575 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4576 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4578 /* Set the c_address field of c_null_ptr and c_null_funptr to
4579 the value of NULL. */
4580 tmp_sym
->value
= gfc_get_expr ();
4581 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4582 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4583 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4584 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4585 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4586 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4587 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4588 c
->expr
->ts
.is_iso_c
= 1;
4594 /* Add a formal argument, gfc_formal_arglist, to the
4595 end of the given list of arguments. Set the reference to the
4596 provided symbol, param_sym, in the argument. */
4599 add_formal_arg (gfc_formal_arglist
**head
,
4600 gfc_formal_arglist
**tail
,
4601 gfc_formal_arglist
*formal_arg
,
4602 gfc_symbol
*param_sym
)
4604 /* Put in list, either as first arg or at the tail (curr arg). */
4606 *head
= *tail
= formal_arg
;
4609 (*tail
)->next
= formal_arg
;
4610 (*tail
) = formal_arg
;
4613 (*tail
)->sym
= param_sym
;
4614 (*tail
)->next
= NULL
;
4620 /* Add a procedure interface to the given symbol (i.e., store a
4621 reference to the list of formal arguments). */
4624 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4627 sym
->formal
= formal
;
4628 sym
->attr
.if_source
= source
;
4632 /* Copy the formal args from an existing symbol, src, into a new
4633 symbol, dest. New formal args are created, and the description of
4634 each arg is set according to the existing ones. This function is
4635 used when creating procedure declaration variables from a procedure
4636 declaration statement (see match_proc_decl()) to create the formal
4637 args based on the args of a given named interface.
4639 When an actual argument list is provided, skip the absent arguments.
4640 To be used together with gfc_se->ignore_optional. */
4643 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4644 gfc_actual_arglist
*actual
)
4646 gfc_formal_arglist
*head
= NULL
;
4647 gfc_formal_arglist
*tail
= NULL
;
4648 gfc_formal_arglist
*formal_arg
= NULL
;
4649 gfc_intrinsic_arg
*curr_arg
= NULL
;
4650 gfc_formal_arglist
*formal_prev
= NULL
;
4651 gfc_actual_arglist
*act_arg
= actual
;
4652 /* Save current namespace so we can change it for formal args. */
4653 gfc_namespace
*parent_ns
= gfc_current_ns
;
4655 /* Create a new namespace, which will be the formal ns (namespace
4656 of the formal args). */
4657 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4658 gfc_current_ns
->proc_name
= dest
;
4660 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4662 /* Skip absent arguments. */
4665 gcc_assert (act_arg
!= NULL
);
4666 if (act_arg
->expr
== NULL
)
4668 act_arg
= act_arg
->next
;
4671 act_arg
= act_arg
->next
;
4673 formal_arg
= gfc_get_formal_arglist ();
4674 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4676 /* May need to copy more info for the symbol. */
4677 formal_arg
->sym
->ts
= curr_arg
->ts
;
4678 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4679 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4680 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4681 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4682 formal_arg
->sym
->attr
.dummy
= 1;
4684 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4685 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4687 /* If this isn't the first arg, set up the next ptr. For the
4688 last arg built, the formal_arg->next will never get set to
4689 anything other than NULL. */
4690 if (formal_prev
!= NULL
)
4691 formal_prev
->next
= formal_arg
;
4693 formal_arg
->next
= NULL
;
4695 formal_prev
= formal_arg
;
4697 /* Add arg to list of formal args. */
4698 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4700 /* Validate changes. */
4701 gfc_commit_symbol (formal_arg
->sym
);
4704 /* Add the interface to the symbol. */
4705 add_proc_interface (dest
, IFSRC_DECL
, head
);
4707 /* Store the formal namespace information. */
4708 if (dest
->formal
!= NULL
)
4709 /* The current ns should be that for the dest proc. */
4710 dest
->formal_ns
= gfc_current_ns
;
4711 /* Restore the current namespace to what it was on entry. */
4712 gfc_current_ns
= parent_ns
;
4717 std_for_isocbinding_symbol (int id
)
4721 #define NAMED_INTCST(a,b,c,d) \
4724 #include "iso-c-binding.def"
4727 #define NAMED_FUNCTION(a,b,c,d) \
4730 #define NAMED_SUBROUTINE(a,b,c,d) \
4733 #include "iso-c-binding.def"
4734 #undef NAMED_FUNCTION
4735 #undef NAMED_SUBROUTINE
4738 return GFC_STD_F2003
;
4742 /* Generate the given set of C interoperable kind objects, or all
4743 interoperable kinds. This function will only be given kind objects
4744 for valid iso_c_binding defined types because this is verified when
4745 the 'use' statement is parsed. If the user gives an 'only' clause,
4746 the specific kinds are looked up; if they don't exist, an error is
4747 reported. If the user does not give an 'only' clause, all
4748 iso_c_binding symbols are generated. If a list of specific kinds
4749 is given, it must have a NULL in the first empty spot to mark the
4750 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4751 point to the symtree for c_(fun)ptr. */
4754 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4755 const char *local_name
, gfc_symtree
*dt_symtree
,
4758 const char *const name
= (local_name
&& local_name
[0])
4759 ? local_name
: c_interop_kinds_table
[s
].name
;
4760 gfc_symtree
*tmp_symtree
;
4761 gfc_symbol
*tmp_sym
= NULL
;
4764 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4767 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4769 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4770 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4771 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4774 /* Already exists in this scope so don't re-add it. */
4775 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4776 && (!tmp_sym
->attr
.generic
4777 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4778 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4780 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4781 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4783 gfc_dt_list
*dt_list
;
4784 dt_list
= gfc_get_dt_list ();
4785 dt_list
->derived
= tmp_sym
;
4786 dt_list
->next
= gfc_derived_types
;
4787 gfc_derived_types
= dt_list
;
4793 /* Create the sym tree in the current ns. */
4796 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4797 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4799 /* Add to the list of tentative symbols. */
4800 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4801 tmp_sym
->old_symbol
= NULL
;
4803 tmp_sym
->gfc_new
= 1;
4805 tmp_symtree
->n
.sym
= tmp_sym
;
4810 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4811 gcc_assert (tmp_symtree
);
4812 tmp_sym
= tmp_symtree
->n
.sym
;
4815 /* Say what module this symbol belongs to. */
4816 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4817 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4818 tmp_sym
->intmod_sym_id
= s
;
4819 tmp_sym
->attr
.is_iso_c
= 1;
4820 tmp_sym
->attr
.use_assoc
= 1;
4822 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4823 || s
== ISOCBINDING_NULL_PTR
);
4828 #define NAMED_INTCST(a,b,c,d) case a :
4829 #define NAMED_REALCST(a,b,c,d) case a :
4830 #define NAMED_CMPXCST(a,b,c,d) case a :
4831 #define NAMED_LOGCST(a,b,c) case a :
4832 #define NAMED_CHARKNDCST(a,b,c) case a :
4833 #include "iso-c-binding.def"
4835 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4836 c_interop_kinds_table
[s
].value
);
4838 /* Initialize an integer constant expression node. */
4839 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4840 tmp_sym
->ts
.type
= BT_INTEGER
;
4841 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4843 /* Mark this type as a C interoperable one. */
4844 tmp_sym
->ts
.is_c_interop
= 1;
4845 tmp_sym
->ts
.is_iso_c
= 1;
4846 tmp_sym
->value
->ts
.is_c_interop
= 1;
4847 tmp_sym
->value
->ts
.is_iso_c
= 1;
4848 tmp_sym
->attr
.is_c_interop
= 1;
4850 /* Tell what f90 type this c interop kind is valid. */
4851 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4856 #define NAMED_CHARCST(a,b,c) case a :
4857 #include "iso-c-binding.def"
4859 /* Initialize an integer constant expression node for the
4860 length of the character. */
4861 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4862 &gfc_current_locus
, NULL
, 1);
4863 tmp_sym
->value
->ts
.is_c_interop
= 1;
4864 tmp_sym
->value
->ts
.is_iso_c
= 1;
4865 tmp_sym
->value
->value
.character
.length
= 1;
4866 tmp_sym
->value
->value
.character
.string
[0]
4867 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4868 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4869 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4872 /* May not need this in both attr and ts, but do need in
4873 attr for writing module file. */
4874 tmp_sym
->attr
.is_c_interop
= 1;
4876 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4877 tmp_sym
->ts
.type
= BT_CHARACTER
;
4879 /* Need to set it to the C_CHAR kind. */
4880 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4882 /* Mark this type as a C interoperable one. */
4883 tmp_sym
->ts
.is_c_interop
= 1;
4884 tmp_sym
->ts
.is_iso_c
= 1;
4886 /* Tell what f90 type this c interop kind is valid. */
4887 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4891 case ISOCBINDING_PTR
:
4892 case ISOCBINDING_FUNPTR
:
4895 gfc_dt_list
**dt_list_ptr
= NULL
;
4896 gfc_component
*tmp_comp
= NULL
;
4898 /* Generate real derived type. */
4903 const char *hidden_name
;
4904 gfc_interface
*intr
, *head
;
4906 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4907 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4909 gcc_assert (tmp_symtree
== NULL
);
4910 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4911 dt_sym
= tmp_symtree
->n
.sym
;
4912 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4913 ? "c_ptr" : "c_funptr");
4915 /* Generate an artificial generic function. */
4916 head
= tmp_sym
->generic
;
4917 intr
= gfc_get_interface ();
4919 intr
->where
= gfc_current_locus
;
4921 tmp_sym
->generic
= intr
;
4923 if (!tmp_sym
->attr
.generic
4924 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4927 if (!tmp_sym
->attr
.function
4928 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4932 /* Say what module this symbol belongs to. */
4933 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4934 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4935 dt_sym
->intmod_sym_id
= s
;
4936 dt_sym
->attr
.use_assoc
= 1;
4938 /* Initialize an integer constant expression node. */
4939 dt_sym
->attr
.flavor
= FL_DERIVED
;
4940 dt_sym
->ts
.is_c_interop
= 1;
4941 dt_sym
->attr
.is_c_interop
= 1;
4942 dt_sym
->attr
.private_comp
= 1;
4943 dt_sym
->component_access
= ACCESS_PRIVATE
;
4944 dt_sym
->ts
.is_iso_c
= 1;
4945 dt_sym
->ts
.type
= BT_DERIVED
;
4946 dt_sym
->ts
.f90_type
= BT_VOID
;
4948 /* A derived type must have the bind attribute to be
4949 interoperable (J3/04-007, Section 15.2.3), even though
4950 the binding label is not used. */
4951 dt_sym
->attr
.is_bind_c
= 1;
4953 dt_sym
->attr
.referenced
= 1;
4954 dt_sym
->ts
.u
.derived
= dt_sym
;
4956 /* Add the symbol created for the derived type to the current ns. */
4957 dt_list_ptr
= &(gfc_derived_types
);
4958 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4959 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4961 /* There is already at least one derived type in the list, so append
4962 the one we're currently building for c_ptr or c_funptr. */
4963 if (*dt_list_ptr
!= NULL
)
4964 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4965 (*dt_list_ptr
) = gfc_get_dt_list ();
4966 (*dt_list_ptr
)->derived
= dt_sym
;
4967 (*dt_list_ptr
)->next
= NULL
;
4969 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4970 if (tmp_comp
== NULL
)
4973 tmp_comp
->ts
.type
= BT_INTEGER
;
4975 /* Set this because the module will need to read/write this field. */
4976 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4978 /* The kinds for c_ptr and c_funptr are the same. */
4979 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4980 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4981 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4983 /* Mark the component as C interoperable. */
4984 tmp_comp
->ts
.is_c_interop
= 1;
4989 case ISOCBINDING_NULL_PTR
:
4990 case ISOCBINDING_NULL_FUNPTR
:
4991 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4997 gfc_commit_symbol (tmp_sym
);
5002 /* Check that a symbol is already typed. If strict is not set, an untyped
5003 symbol is acceptable for non-standard-conforming mode. */
5006 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5007 bool strict
, locus where
)
5011 if (gfc_matching_prefix
)
5014 /* Check for the type and try to give it an implicit one. */
5015 if (sym
->ts
.type
== BT_UNKNOWN
5016 && !gfc_set_default_type (sym
, 0, ns
))
5020 gfc_error ("Symbol %qs is used before it is typed at %L",
5025 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5026 " it is typed at %L", sym
->name
, &where
))
5030 /* Everything is ok. */
5035 /* Construct a typebound-procedure structure. Those are stored in a tentative
5036 list and marked `error' until symbols are committed. */
5039 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5041 gfc_typebound_proc
*result
;
5043 result
= XCNEW (gfc_typebound_proc
);
5048 latest_undo_chgset
->tbps
.safe_push (result
);
5054 /* Get the super-type of a given derived type. */
5057 gfc_get_derived_super_type (gfc_symbol
* derived
)
5059 gcc_assert (derived
);
5061 if (derived
->attr
.generic
)
5062 derived
= gfc_find_dt_in_generic (derived
);
5064 if (!derived
->attr
.extension
)
5067 gcc_assert (derived
->components
);
5068 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5069 gcc_assert (derived
->components
->ts
.u
.derived
);
5071 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5072 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5074 return derived
->components
->ts
.u
.derived
;
5078 /* Get the ultimate super-type of a given derived type. */
5081 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
5083 if (!derived
->attr
.extension
)
5086 derived
= gfc_get_derived_super_type (derived
);
5088 if (derived
->attr
.extension
)
5089 return gfc_get_ultimate_derived_super_type (derived
);
5095 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5098 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5100 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5101 t2
= gfc_get_derived_super_type (t2
);
5102 return gfc_compare_derived_types (t1
, t2
);
5106 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5107 If ts1 is nonpolymorphic, ts2 must be the same type.
5108 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5111 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5113 bool is_class1
= (ts1
->type
== BT_CLASS
);
5114 bool is_class2
= (ts2
->type
== BT_CLASS
);
5115 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5116 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5117 bool is_union1
= (ts1
->type
== BT_UNION
);
5118 bool is_union2
= (ts2
->type
== BT_UNION
);
5121 && ts1
->u
.derived
->components
5122 && ((ts1
->u
.derived
->attr
.is_class
5123 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5124 .unlimited_polymorphic
)
5125 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5128 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5129 && !is_union1
&& !is_union2
)
5130 return (ts1
->type
== ts2
->type
);
5132 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5133 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5135 if (is_derived1
&& is_class2
)
5136 return gfc_compare_derived_types (ts1
->u
.derived
,
5137 ts2
->u
.derived
->attr
.is_class
?
5138 ts2
->u
.derived
->components
->ts
.u
.derived
5140 if (is_class1
&& is_derived2
)
5141 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5142 ts1
->u
.derived
->components
->ts
.u
.derived
5145 else if (is_class1
&& is_class2
)
5146 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5147 ts1
->u
.derived
->components
->ts
.u
.derived
5149 ts2
->u
.derived
->attr
.is_class
?
5150 ts2
->u
.derived
->components
->ts
.u
.derived
5157 /* Find the parent-namespace of the current function. If we're inside
5158 BLOCK constructs, it may not be the current one. */
5161 gfc_find_proc_namespace (gfc_namespace
* ns
)
5163 while (ns
->construct_entities
)
5173 /* Check if an associate-variable should be translated as an `implicit' pointer
5174 internally (if it is associated to a variable and not an array with
5178 gfc_is_associate_pointer (gfc_symbol
* sym
)
5183 if (sym
->ts
.type
== BT_CLASS
)
5186 if (sym
->ts
.type
== BT_CHARACTER
5188 && sym
->assoc
->target
5189 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5192 if (!sym
->assoc
->variable
)
5195 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5203 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5205 gfc_interface
*intr
= NULL
;
5207 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5210 if (sym
->attr
.generic
)
5211 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5212 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5214 return intr
? intr
->sym
: NULL
;
5218 /* Get the dummy arguments from a procedure symbol. If it has been declared
5219 via a PROCEDURE statement with a named interface, ts.interface will be set
5220 and the arguments need to be taken from there. */
5222 gfc_formal_arglist
*
5223 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5225 gfc_formal_arglist
*dummies
;
5227 dummies
= sym
->formal
;
5228 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5229 dummies
= sym
->ts
.interface
->formal
;