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 attr
->volatile_
= 1;
1353 attr
->volatile_ns
= gfc_current_ns
;
1354 return check_conflict (attr
, name
, where
);
1359 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1361 /* No check_used needed as 11.2.1 of the F2003 standard allows
1362 that the local identifier made accessible by a use statement can be
1363 given a ASYNCHRONOUS attribute. */
1365 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1366 if (!gfc_notify_std (GFC_STD_LEGACY
,
1367 "Duplicate ASYNCHRONOUS attribute specified at %L",
1371 attr
->asynchronous
= 1;
1372 attr
->asynchronous_ns
= gfc_current_ns
;
1373 return check_conflict (attr
, name
, where
);
1378 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1381 if (check_used (attr
, name
, where
))
1384 if (attr
->threadprivate
)
1386 duplicate_attr ("THREADPRIVATE", where
);
1390 attr
->threadprivate
= 1;
1391 return check_conflict (attr
, name
, where
);
1396 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1400 if (check_used (attr
, name
, where
))
1403 if (attr
->omp_declare_target
)
1406 attr
->omp_declare_target
= 1;
1407 return check_conflict (attr
, name
, where
);
1412 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1416 if (check_used (attr
, name
, where
))
1419 if (attr
->omp_declare_target_link
)
1422 attr
->omp_declare_target_link
= 1;
1423 return check_conflict (attr
, name
, where
);
1428 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1431 if (check_used (attr
, name
, where
))
1434 if (attr
->oacc_declare_create
)
1437 attr
->oacc_declare_create
= 1;
1438 return check_conflict (attr
, name
, where
);
1443 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1446 if (check_used (attr
, name
, where
))
1449 if (attr
->oacc_declare_copyin
)
1452 attr
->oacc_declare_copyin
= 1;
1453 return check_conflict (attr
, name
, where
);
1458 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1461 if (check_used (attr
, name
, where
))
1464 if (attr
->oacc_declare_deviceptr
)
1467 attr
->oacc_declare_deviceptr
= 1;
1468 return check_conflict (attr
, name
, where
);
1473 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1476 if (check_used (attr
, name
, where
))
1479 if (attr
->oacc_declare_device_resident
)
1482 attr
->oacc_declare_device_resident
= 1;
1483 return check_conflict (attr
, name
, where
);
1488 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1491 if (check_used (attr
, NULL
, where
))
1496 duplicate_attr ("TARGET", where
);
1501 return check_conflict (attr
, NULL
, where
);
1506 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1509 if (check_used (attr
, name
, where
))
1512 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1514 return check_conflict (attr
, name
, where
);
1519 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1522 if (check_used (attr
, name
, where
))
1525 /* Duplicate attribute already checked for. */
1526 attr
->in_common
= 1;
1527 return check_conflict (attr
, name
, where
);
1532 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1535 /* Duplicate attribute already checked for. */
1536 attr
->in_equivalence
= 1;
1537 if (!check_conflict (attr
, name
, where
))
1540 if (attr
->flavor
== FL_VARIABLE
)
1543 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1548 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1551 if (check_used (attr
, name
, where
))
1555 return check_conflict (attr
, name
, where
);
1560 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1563 attr
->in_namelist
= 1;
1564 return check_conflict (attr
, name
, where
);
1569 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1572 if (check_used (attr
, name
, where
))
1576 return check_conflict (attr
, name
, where
);
1581 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1584 if (check_used (attr
, NULL
, where
))
1587 if (attr
->elemental
)
1589 duplicate_attr ("ELEMENTAL", where
);
1593 attr
->elemental
= 1;
1594 return check_conflict (attr
, NULL
, where
);
1599 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1602 if (check_used (attr
, NULL
, where
))
1607 duplicate_attr ("PURE", where
);
1612 return check_conflict (attr
, NULL
, where
);
1617 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1620 if (check_used (attr
, NULL
, where
))
1623 if (attr
->recursive
)
1625 duplicate_attr ("RECURSIVE", where
);
1629 attr
->recursive
= 1;
1630 return check_conflict (attr
, NULL
, where
);
1635 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1638 if (check_used (attr
, name
, where
))
1643 duplicate_attr ("ENTRY", where
);
1648 return check_conflict (attr
, name
, where
);
1653 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1656 if (attr
->flavor
!= FL_PROCEDURE
1657 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1661 return check_conflict (attr
, name
, where
);
1666 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1669 if (attr
->flavor
!= FL_PROCEDURE
1670 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1673 attr
->subroutine
= 1;
1674 return check_conflict (attr
, name
, where
);
1679 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1682 if (attr
->flavor
!= FL_PROCEDURE
1683 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1687 return check_conflict (attr
, name
, where
);
1692 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1695 if (check_used (attr
, NULL
, where
))
1698 if (attr
->flavor
!= FL_PROCEDURE
1699 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1702 if (attr
->procedure
)
1704 duplicate_attr ("PROCEDURE", where
);
1708 attr
->procedure
= 1;
1710 return check_conflict (attr
, NULL
, where
);
1715 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1719 duplicate_attr ("ABSTRACT", where
);
1725 return check_conflict (attr
, NULL
, where
);
1729 /* Flavors are special because some flavors are not what Fortran
1730 considers attributes and can be reaffirmed multiple times. */
1733 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1737 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1738 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1739 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1742 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1745 /* Copying a procedure dummy argument for a module procedure in a
1746 submodule results in the flavor being copied and would result in
1747 an error without this. */
1748 if (gfc_new_block
&& gfc_new_block
->abr_modproc_decl
1749 && attr
->flavor
== f
&& f
== FL_PROCEDURE
)
1752 if (attr
->flavor
!= FL_UNKNOWN
)
1755 where
= &gfc_current_locus
;
1758 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1759 gfc_code2string (flavors
, attr
->flavor
), name
,
1760 gfc_code2string (flavors
, f
), where
);
1762 gfc_error ("%s attribute conflicts with %s attribute at %L",
1763 gfc_code2string (flavors
, attr
->flavor
),
1764 gfc_code2string (flavors
, f
), where
);
1771 return check_conflict (attr
, name
, where
);
1776 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1777 const char *name
, locus
*where
)
1780 if (check_used (attr
, name
, where
))
1783 if (attr
->flavor
!= FL_PROCEDURE
1784 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1788 where
= &gfc_current_locus
;
1790 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
)
1792 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1793 && !gfc_notification_std (GFC_STD_F2008
))
1794 gfc_error ("%s procedure at %L is already declared as %s "
1795 "procedure. \nF2008: A pointer function assignment "
1796 "is ambiguous if it is the first executable statement "
1797 "after the specification block. Please add any other "
1798 "kind of executable statement before it. FIXME",
1799 gfc_code2string (procedures
, t
), where
,
1800 gfc_code2string (procedures
, attr
->proc
));
1802 gfc_error ("%s procedure at %L is already declared as %s "
1803 "procedure", gfc_code2string (procedures
, t
), where
,
1804 gfc_code2string (procedures
, attr
->proc
));
1811 /* Statement functions are always scalar and functions. */
1812 if (t
== PROC_ST_FUNCTION
1813 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1814 || attr
->dimension
))
1817 return check_conflict (attr
, name
, where
);
1822 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1825 if (check_used (attr
, NULL
, where
))
1828 if (attr
->intent
== INTENT_UNKNOWN
)
1830 attr
->intent
= intent
;
1831 return check_conflict (attr
, NULL
, where
);
1835 where
= &gfc_current_locus
;
1837 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1838 gfc_intent_string (attr
->intent
),
1839 gfc_intent_string (intent
), where
);
1845 /* No checks for use-association in public and private statements. */
1848 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1849 const char *name
, locus
*where
)
1852 if (attr
->access
== ACCESS_UNKNOWN
1853 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1855 attr
->access
= access
;
1856 return check_conflict (attr
, name
, where
);
1860 where
= &gfc_current_locus
;
1861 gfc_error ("ACCESS specification at %L was already specified", where
);
1867 /* Set the is_bind_c field for the given symbol_attribute. */
1870 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1871 int is_proc_lang_bind_spec
)
1874 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1875 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1876 "variables or common blocks", where
);
1877 else if (attr
->is_bind_c
)
1878 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1880 attr
->is_bind_c
= 1;
1883 where
= &gfc_current_locus
;
1885 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1888 return check_conflict (attr
, name
, where
);
1892 /* Set the extension field for the given symbol_attribute. */
1895 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1898 where
= &gfc_current_locus
;
1900 if (attr
->extension
)
1901 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1903 attr
->extension
= 1;
1905 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1913 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1914 gfc_formal_arglist
* formal
, locus
*where
)
1916 if (check_used (&sym
->attr
, sym
->name
, where
))
1919 /* Skip the following checks in the case of a module_procedures in a
1920 submodule since they will manifestly fail. */
1921 if (sym
->attr
.module_procedure
== 1
1922 && source
== IFSRC_DECL
)
1926 where
= &gfc_current_locus
;
1928 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1929 && sym
->attr
.if_source
!= IFSRC_DECL
)
1931 gfc_error ("Symbol %qs at %L already has an explicit interface",
1936 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1938 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1939 "body", sym
->name
, where
);
1944 sym
->formal
= formal
;
1945 sym
->attr
.if_source
= source
;
1951 /* Add a type to a symbol. */
1954 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1960 where
= &gfc_current_locus
;
1963 type
= sym
->result
->ts
.type
;
1965 type
= sym
->ts
.type
;
1967 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1968 type
= sym
->ns
->proc_name
->ts
.type
;
1970 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1971 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1972 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
1973 && !sym
->attr
.module_procedure
)
1975 if (sym
->attr
.use_assoc
)
1976 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
1977 "use-associated at %L", sym
->name
, where
, sym
->module
,
1980 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
1981 where
, gfc_basic_typename (type
));
1985 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1987 gfc_error ("Procedure %qs at %L may not have basic type of %s",
1988 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1992 flavor
= sym
->attr
.flavor
;
1994 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1995 || flavor
== FL_LABEL
1996 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1997 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1999 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
2008 /* Clears all attributes. */
2011 gfc_clear_attr (symbol_attribute
*attr
)
2013 memset (attr
, 0, sizeof (symbol_attribute
));
2017 /* Check for missing attributes in the new symbol. Currently does
2018 nothing, but it's not clear that it is unnecessary yet. */
2021 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
2022 locus
*where ATTRIBUTE_UNUSED
)
2029 /* Copy an attribute to a symbol attribute, bit by bit. Some
2030 attributes have a lot of side-effects but cannot be present given
2031 where we are called from, so we ignore some bits. */
2034 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
2036 int is_proc_lang_bind_spec
;
2038 /* In line with the other attributes, we only add bits but do not remove
2039 them; cf. also PR 41034. */
2040 dest
->ext_attr
|= src
->ext_attr
;
2042 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
2045 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
2047 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
2049 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
2051 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
2053 if (src
->optional
&& !gfc_add_optional (dest
, where
))
2055 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
2057 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
2059 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
2061 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
2063 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2065 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2067 if (src
->threadprivate
2068 && !gfc_add_threadprivate (dest
, NULL
, where
))
2070 if (src
->omp_declare_target
2071 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2073 if (src
->omp_declare_target_link
2074 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2076 if (src
->oacc_declare_create
2077 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2079 if (src
->oacc_declare_copyin
2080 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2082 if (src
->oacc_declare_deviceptr
2083 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2085 if (src
->oacc_declare_device_resident
2086 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2088 if (src
->target
&& !gfc_add_target (dest
, where
))
2090 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2092 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2097 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2100 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2103 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2105 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2107 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2110 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2112 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2114 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2116 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2119 if (src
->flavor
!= FL_UNKNOWN
2120 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2123 if (src
->intent
!= INTENT_UNKNOWN
2124 && !gfc_add_intent (dest
, src
->intent
, where
))
2127 if (src
->access
!= ACCESS_UNKNOWN
2128 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2131 if (!gfc_missing_attr (dest
, where
))
2134 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2136 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2139 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2141 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2144 if (src
->is_c_interop
)
2145 dest
->is_c_interop
= 1;
2149 if (src
->external
&& !gfc_add_external (dest
, where
))
2151 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2153 if (src
->proc_pointer
)
2154 dest
->proc_pointer
= 1;
2163 /* A function to generate a dummy argument symbol using that from the
2164 interface declaration. Can be used for the result symbol as well if
2168 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2172 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2176 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2179 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2180 &gfc_current_locus
))
2183 if ((*dsym
)->attr
.dimension
)
2184 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2186 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2188 if ((*dsym
) != NULL
&& !result
2189 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2190 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2192 else if ((*dsym
) != NULL
&& result
2193 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2194 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2201 /************** Component name management ************/
2203 /* Component names of a derived type form their own little namespaces
2204 that are separate from all other spaces. The space is composed of
2205 a singly linked list of gfc_component structures whose head is
2206 located in the parent symbol. */
2209 /* Add a component name to a symbol. The call fails if the name is
2210 already present. On success, the component pointer is modified to
2211 point to the additional component structure. */
2214 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2215 gfc_component
**component
)
2217 gfc_component
*p
, *tail
;
2219 /* Check for existing components with the same name, but not for union
2220 components or containers. Unions and maps are anonymous so they have
2221 unique internal names which will never conflict.
2222 Don't use gfc_find_component here because it calls gfc_use_derived,
2223 but the derived type may not be fully defined yet. */
2226 for (p
= sym
->components
; p
; p
= p
->next
)
2228 if (strcmp (p
->name
, name
) == 0)
2230 gfc_error ("Component %qs at %C already declared at %L",
2238 if (sym
->attr
.extension
2239 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2240 name
, true, true, NULL
))
2242 gfc_error ("Component %qs at %C already in the parent type "
2243 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2247 /* Allocate a new component. */
2248 p
= gfc_get_component ();
2251 sym
->components
= p
;
2255 p
->name
= gfc_get_string ("%s", name
);
2256 p
->loc
= gfc_current_locus
;
2257 p
->ts
.type
= BT_UNKNOWN
;
2264 /* Recursive function to switch derived types of all symbol in a
2268 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2276 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2277 sym
->ts
.u
.derived
= to
;
2279 switch_types (st
->left
, from
, to
);
2280 switch_types (st
->right
, from
, to
);
2284 /* This subroutine is called when a derived type is used in order to
2285 make the final determination about which version to use. The
2286 standard requires that a type be defined before it is 'used', but
2287 such types can appear in IMPLICIT statements before the actual
2288 definition. 'Using' in this context means declaring a variable to
2289 be that type or using the type constructor.
2291 If a type is used and the components haven't been defined, then we
2292 have to have a derived type in a parent unit. We find the node in
2293 the other namespace and point the symtree node in this namespace to
2294 that node. Further reference to this name point to the correct
2295 node. If we can't find the node in a parent namespace, then we have
2298 This subroutine takes a pointer to a symbol node and returns a
2299 pointer to the translated node or NULL for an error. Usually there
2300 is no translation and we return the node we were passed. */
2303 gfc_use_derived (gfc_symbol
*sym
)
2313 if (sym
->attr
.unlimited_polymorphic
)
2316 if (sym
->attr
.generic
)
2317 sym
= gfc_find_dt_in_generic (sym
);
2319 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2320 return sym
; /* Already defined. */
2322 if (sym
->ns
->parent
== NULL
)
2325 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2327 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2331 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2334 /* Get rid of symbol sym, translating all references to s. */
2335 for (i
= 0; i
< GFC_LETTERS
; i
++)
2337 t
= &sym
->ns
->default_type
[i
];
2338 if (t
->u
.derived
== sym
)
2342 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2347 /* Unlink from list of modified symbols. */
2348 gfc_commit_symbol (sym
);
2350 switch_types (sym
->ns
->sym_root
, sym
, s
);
2352 /* TODO: Also have to replace sym -> s in other lists like
2353 namelists, common lists and interface lists. */
2354 gfc_free_symbol (sym
);
2359 gfc_error ("Derived type %qs at %C is being used before it is defined",
2365 /* Find the component with the given name in the union type symbol.
2366 If ref is not NULL it will be set to the chain of components through which
2367 the component can actually be accessed. This is necessary for unions because
2368 intermediate structures may be maps, nested structures, or other unions,
2369 all of which may (or must) be 'anonymous' to user code. */
2371 static gfc_component
*
2372 find_union_component (gfc_symbol
*un
, const char *name
,
2373 bool noaccess
, gfc_ref
**ref
)
2375 gfc_component
*m
, *check
;
2376 gfc_ref
*sref
, *tmp
;
2378 for (m
= un
->components
; m
; m
= m
->next
)
2380 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2384 /* Found component somewhere in m; chain the refs together. */
2388 sref
= gfc_get_ref ();
2389 sref
->type
= REF_COMPONENT
;
2390 sref
->u
.c
.component
= m
;
2391 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2396 /* Other checks (such as access) were done in the recursive calls. */
2403 /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2404 the number of total candidates in CANDIDATES_LEN. */
2407 lookup_component_fuzzy_find_candidates (gfc_component
*component
,
2409 size_t &candidates_len
)
2411 for (gfc_component
*p
= component
; p
; p
= p
->next
)
2412 vec_push (candidates
, candidates_len
, p
->name
);
2416 /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2419 lookup_component_fuzzy (const char *member
, gfc_component
*component
)
2421 char **candidates
= NULL
;
2422 size_t candidates_len
= 0;
2423 lookup_component_fuzzy_find_candidates (component
, candidates
,
2425 return gfc_closest_fuzzy_match (member
, candidates
);
2429 /* Given a derived type node and a component name, try to locate the
2430 component structure. Returns the NULL pointer if the component is
2431 not found or the components are private. If noaccess is set, no access
2432 checks are done. If silent is set, an error will not be generated if
2433 the component cannot be found or accessed.
2435 If ref is not NULL, *ref is set to represent the chain of components
2436 required to get to the ultimate component.
2438 If the component is simply a direct subcomponent, or is inherited from a
2439 parent derived type in the given derived type, this is a single ref with its
2440 component set to the returned component.
2442 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2443 when the component is found through an implicit chain of nested union and
2444 map components. Unions and maps are "anonymous" substructures in FORTRAN
2445 which cannot be explicitly referenced, but the reference chain must be
2446 considered as in C for backend translation to correctly compute layouts.
2447 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2450 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2451 bool noaccess
, bool silent
, gfc_ref
**ref
)
2453 gfc_component
*p
, *check
;
2454 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2456 if (name
== NULL
|| sym
== NULL
)
2459 if (sym
->attr
.flavor
== FL_DERIVED
)
2460 sym
= gfc_use_derived (sym
);
2462 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2467 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2468 if (sym
->attr
.flavor
== FL_UNION
)
2469 return find_union_component (sym
, name
, noaccess
, ref
);
2471 if (ref
) *ref
= NULL
;
2472 for (p
= sym
->components
; p
; p
= p
->next
)
2474 /* Nest search into union's maps. */
2475 if (p
->ts
.type
== BT_UNION
)
2477 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2483 sref
= gfc_get_ref ();
2484 sref
->type
= REF_COMPONENT
;
2485 sref
->u
.c
.component
= p
;
2486 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2493 else if (strcmp (p
->name
, name
) == 0)
2499 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2501 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2502 if (p
->attr
.access
== ACCESS_PRIVATE
||
2503 (p
->attr
.access
!= ACCESS_PUBLIC
2504 && sym
->component_access
== ACCESS_PRIVATE
2505 && !is_parent_comp
))
2508 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2515 && sym
->attr
.extension
2516 && sym
->components
->ts
.type
== BT_DERIVED
)
2518 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2519 noaccess
, silent
, ref
);
2520 /* Do not overwrite the error. */
2525 if (p
== NULL
&& !silent
)
2527 const char *guessed
= lookup_component_fuzzy (name
, sym
->components
);
2529 gfc_error ("%qs at %C is not a member of the %qs structure"
2530 "; did you mean %qs?",
2531 name
, sym
->name
, guessed
);
2533 gfc_error ("%qs at %C is not a member of the %qs structure",
2537 /* Component was found; build the ultimate component reference. */
2538 if (p
!= NULL
&& ref
)
2540 tmp
= gfc_get_ref ();
2541 tmp
->type
= REF_COMPONENT
;
2542 tmp
->u
.c
.component
= p
;
2544 /* Link the final component ref to the end of the chain of subrefs. */
2548 for (; sref
->next
; sref
= sref
->next
)
2560 /* Given a symbol, free all of the component structures and everything
2564 free_components (gfc_component
*p
)
2572 gfc_free_array_spec (p
->as
);
2573 gfc_free_expr (p
->initializer
);
2575 gfc_free_expr (p
->kind_expr
);
2577 gfc_free_actual_arglist (p
->param_list
);
2585 /******************** Statement label management ********************/
2587 /* Comparison function for statement labels, used for managing the
2591 compare_st_labels (void *a1
, void *b1
)
2593 int a
= ((gfc_st_label
*) a1
)->value
;
2594 int b
= ((gfc_st_label
*) b1
)->value
;
2600 /* Free a single gfc_st_label structure, making sure the tree is not
2601 messed up. This function is called only when some parse error
2605 gfc_free_st_label (gfc_st_label
*label
)
2611 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2613 if (label
->format
!= NULL
)
2614 gfc_free_expr (label
->format
);
2620 /* Free a whole tree of gfc_st_label structures. */
2623 free_st_labels (gfc_st_label
*label
)
2629 free_st_labels (label
->left
);
2630 free_st_labels (label
->right
);
2632 if (label
->format
!= NULL
)
2633 gfc_free_expr (label
->format
);
2638 /* Given a label number, search for and return a pointer to the label
2639 structure, creating it if it does not exist. */
2642 gfc_get_st_label (int labelno
)
2647 if (gfc_current_state () == COMP_DERIVED
)
2648 ns
= gfc_current_block ()->f2k_derived
;
2651 /* Find the namespace of the scoping unit:
2652 If we're in a BLOCK construct, jump to the parent namespace. */
2653 ns
= gfc_current_ns
;
2654 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2658 /* First see if the label is already in this namespace. */
2662 if (lp
->value
== labelno
)
2665 if (lp
->value
< labelno
)
2671 lp
= XCNEW (gfc_st_label
);
2673 lp
->value
= labelno
;
2674 lp
->defined
= ST_LABEL_UNKNOWN
;
2675 lp
->referenced
= ST_LABEL_UNKNOWN
;
2678 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2684 /* Called when a statement with a statement label is about to be
2685 accepted. We add the label to the list of the current namespace,
2686 making sure it hasn't been defined previously and referenced
2690 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2694 labelno
= lp
->value
;
2696 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2697 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2698 &lp
->where
, label_locus
);
2701 lp
->where
= *label_locus
;
2705 case ST_LABEL_FORMAT
:
2706 if (lp
->referenced
== ST_LABEL_TARGET
2707 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2708 gfc_error ("Label %d at %C already referenced as branch target",
2711 lp
->defined
= ST_LABEL_FORMAT
;
2715 case ST_LABEL_TARGET
:
2716 case ST_LABEL_DO_TARGET
:
2717 if (lp
->referenced
== ST_LABEL_FORMAT
)
2718 gfc_error ("Label %d at %C already referenced as a format label",
2723 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2724 && !gfc_notify_std (GFC_STD_F95_OBS
, "DO termination statement "
2725 "which is not END DO or CONTINUE with "
2726 "label %d at %C", labelno
))
2731 lp
->defined
= ST_LABEL_BAD_TARGET
;
2732 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2738 /* Reference a label. Given a label and its type, see if that
2739 reference is consistent with what is known about that label,
2740 updating the unknown state. Returns false if something goes
2744 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2746 gfc_sl_type label_type
;
2753 labelno
= lp
->value
;
2755 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2756 label_type
= lp
->defined
;
2759 label_type
= lp
->referenced
;
2760 lp
->where
= gfc_current_locus
;
2763 if (label_type
== ST_LABEL_FORMAT
2764 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2766 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2771 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2772 || label_type
== ST_LABEL_BAD_TARGET
)
2773 && type
== ST_LABEL_FORMAT
)
2775 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2780 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2781 && !gfc_notify_std (GFC_STD_F95_OBS
, "Shared DO termination label %d "
2785 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2786 lp
->referenced
= type
;
2794 /************** Symbol table management subroutines ****************/
2796 /* Basic details: Fortran 95 requires a potentially unlimited number
2797 of distinct namespaces when compiling a program unit. This case
2798 occurs during a compilation of internal subprograms because all of
2799 the internal subprograms must be read before we can start
2800 generating code for the host.
2802 Given the tricky nature of the Fortran grammar, we must be able to
2803 undo changes made to a symbol table if the current interpretation
2804 of a statement is found to be incorrect. Whenever a symbol is
2805 looked up, we make a copy of it and link to it. All of these
2806 symbols are kept in a vector so that we can commit or
2807 undo the changes at a later time.
2809 A symtree may point to a symbol node outside of its namespace. In
2810 this case, that symbol has been used as a host associated variable
2811 at some previous time. */
2813 /* Allocate a new namespace structure. Copies the implicit types from
2814 PARENT if PARENT_TYPES is set. */
2817 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2824 ns
= XCNEW (gfc_namespace
);
2825 ns
->sym_root
= NULL
;
2826 ns
->uop_root
= NULL
;
2827 ns
->tb_sym_root
= NULL
;
2828 ns
->finalizers
= NULL
;
2829 ns
->default_access
= ACCESS_UNKNOWN
;
2830 ns
->parent
= parent
;
2832 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2834 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2835 ns
->tb_op
[in
] = NULL
;
2838 /* Initialize default implicit types. */
2839 for (i
= 'a'; i
<= 'z'; i
++)
2841 ns
->set_flag
[i
- 'a'] = 0;
2842 ts
= &ns
->default_type
[i
- 'a'];
2844 if (parent_types
&& ns
->parent
!= NULL
)
2846 /* Copy parent settings. */
2847 *ts
= ns
->parent
->default_type
[i
- 'a'];
2851 if (flag_implicit_none
!= 0)
2857 if ('i' <= i
&& i
<= 'n')
2859 ts
->type
= BT_INTEGER
;
2860 ts
->kind
= gfc_default_integer_kind
;
2865 ts
->kind
= gfc_default_real_kind
;
2869 if (parent_types
&& ns
->parent
!= NULL
)
2870 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2878 /* Comparison function for symtree nodes. */
2881 compare_symtree (void *_st1
, void *_st2
)
2883 gfc_symtree
*st1
, *st2
;
2885 st1
= (gfc_symtree
*) _st1
;
2886 st2
= (gfc_symtree
*) _st2
;
2888 return strcmp (st1
->name
, st2
->name
);
2892 /* Allocate a new symtree node and associate it with the new symbol. */
2895 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2899 st
= XCNEW (gfc_symtree
);
2900 st
->name
= gfc_get_string ("%s", name
);
2902 gfc_insert_bbt (root
, st
, compare_symtree
);
2907 /* Delete a symbol from the tree. Does not free the symbol itself! */
2910 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2912 gfc_symtree st
, *st0
;
2915 /* Submodules are marked as mod.submod. When freeing a submodule
2916 symbol, the symtree only has "submod", so adjust that here. */
2918 p
= strrchr(name
, '.');
2924 st0
= gfc_find_symtree (*root
, p
);
2926 st
.name
= gfc_get_string ("%s", p
);
2927 gfc_delete_bbt (root
, &st
, compare_symtree
);
2933 /* Given a root symtree node and a name, try to find the symbol within
2934 the namespace. Returns NULL if the symbol is not found. */
2937 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2943 c
= strcmp (name
, st
->name
);
2947 st
= (c
< 0) ? st
->left
: st
->right
;
2954 /* Return a symtree node with a name that is guaranteed to be unique
2955 within the namespace and corresponds to an illegal fortran name. */
2958 gfc_get_unique_symtree (gfc_namespace
*ns
)
2960 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2961 static int serial
= 0;
2963 sprintf (name
, "@%d", serial
++);
2964 return gfc_new_symtree (&ns
->sym_root
, name
);
2968 /* Given a name find a user operator node, creating it if it doesn't
2969 exist. These are much simpler than symbols because they can't be
2970 ambiguous with one another. */
2973 gfc_get_uop (const char *name
)
2977 gfc_namespace
*ns
= gfc_current_ns
;
2981 st
= gfc_find_symtree (ns
->uop_root
, name
);
2985 st
= gfc_new_symtree (&ns
->uop_root
, name
);
2987 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2988 uop
->name
= gfc_get_string ("%s", name
);
2989 uop
->access
= ACCESS_UNKNOWN
;
2996 /* Given a name find the user operator node. Returns NULL if it does
3000 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
3005 ns
= gfc_current_ns
;
3007 st
= gfc_find_symtree (ns
->uop_root
, name
);
3008 return (st
== NULL
) ? NULL
: st
->n
.uop
;
3012 /* Update a symbol's common_block field, and take care of the associated
3013 memory management. */
3016 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
3018 if (sym
->common_block
== common_block
)
3021 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
3023 sym
->common_block
->refs
--;
3024 if (sym
->common_block
->refs
== 0)
3025 free (sym
->common_block
);
3027 sym
->common_block
= common_block
;
3031 /* Remove a gfc_symbol structure and everything it points to. */
3034 gfc_free_symbol (gfc_symbol
*sym
)
3040 gfc_free_array_spec (sym
->as
);
3042 free_components (sym
->components
);
3044 gfc_free_expr (sym
->value
);
3046 gfc_free_namelist (sym
->namelist
);
3048 if (sym
->ns
!= sym
->formal_ns
)
3049 gfc_free_namespace (sym
->formal_ns
);
3051 if (!sym
->attr
.generic_copy
)
3052 gfc_free_interface (sym
->generic
);
3054 gfc_free_formal_arglist (sym
->formal
);
3056 gfc_free_namespace (sym
->f2k_derived
);
3058 set_symbol_common_block (sym
, NULL
);
3060 if (sym
->param_list
)
3061 gfc_free_actual_arglist (sym
->param_list
);
3067 /* Decrease the reference counter and free memory when we reach zero. */
3070 gfc_release_symbol (gfc_symbol
*sym
)
3075 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
3076 && (!sym
->attr
.entry
|| !sym
->module
))
3078 /* As formal_ns contains a reference to sym, delete formal_ns just
3079 before the deletion of sym. */
3080 gfc_namespace
*ns
= sym
->formal_ns
;
3081 sym
->formal_ns
= NULL
;
3082 gfc_free_namespace (ns
);
3089 gcc_assert (sym
->refs
== 0);
3090 gfc_free_symbol (sym
);
3094 /* Allocate and initialize a new symbol node. */
3097 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3101 p
= XCNEW (gfc_symbol
);
3103 gfc_clear_ts (&p
->ts
);
3104 gfc_clear_attr (&p
->attr
);
3107 p
->declared_at
= gfc_current_locus
;
3109 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
3110 gfc_internal_error ("new_symbol(): Symbol name too long");
3112 p
->name
= gfc_get_string ("%s", name
);
3114 /* Make sure flags for symbol being C bound are clear initially. */
3115 p
->attr
.is_bind_c
= 0;
3116 p
->attr
.is_iso_c
= 0;
3118 /* Clear the ptrs we may need. */
3119 p
->common_block
= NULL
;
3120 p
->f2k_derived
= NULL
;
3122 p
->fn_result_spec
= 0;
3128 /* Generate an error if a symbol is ambiguous. */
3131 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3134 if (st
->n
.sym
->module
)
3135 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3136 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3138 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3139 "from current program unit", name
, st
->n
.sym
->name
);
3143 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3144 selector on the stack. If yes, replace it by the corresponding temporary. */
3147 select_type_insert_tmp (gfc_symtree
**st
)
3149 gfc_select_type_stack
*stack
= select_type_stack
;
3150 for (; stack
; stack
= stack
->prev
)
3151 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3154 select_type_insert_tmp (st
);
3160 /* Look for a symtree in the current procedure -- that is, go up to
3161 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3164 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3168 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3172 if (!ns
->construct_entities
)
3181 /* Search for a symtree starting in the current namespace, resorting to
3182 any parent namespaces if requested by a nonzero parent_flag.
3183 Returns nonzero if the name is ambiguous. */
3186 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3187 gfc_symtree
**result
)
3192 ns
= gfc_current_ns
;
3196 st
= gfc_find_symtree (ns
->sym_root
, name
);
3199 select_type_insert_tmp (&st
);
3202 /* Ambiguous generic interfaces are permitted, as long
3203 as the specific interfaces are different. */
3204 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3206 ambiguous_symbol (name
, st
);
3216 /* Don't escape an interface block. */
3217 if (ns
&& !ns
->has_import_set
3218 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3225 if (gfc_current_state() == COMP_DERIVED
3226 && gfc_current_block ()->attr
.pdt_template
)
3228 gfc_symbol
*der
= gfc_current_block ();
3229 for (; der
; der
= gfc_get_derived_super_type (der
))
3231 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3233 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3248 /* Same, but returns the symbol instead. */
3251 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3252 gfc_symbol
**result
)
3257 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3262 *result
= st
->n
.sym
;
3268 /* Tells whether there is only one set of changes in the stack. */
3271 single_undo_checkpoint_p (void)
3273 if (latest_undo_chgset
== &default_undo_chgset_var
)
3275 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3280 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3285 /* Save symbol with the information necessary to back it out. */
3288 gfc_save_symbol_data (gfc_symbol
*sym
)
3293 if (!single_undo_checkpoint_p ())
3295 /* If there is more than one change set, look for the symbol in the
3296 current one. If it is found there, we can reuse it. */
3297 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3300 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3304 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3307 s
= XCNEW (gfc_symbol
);
3309 sym
->old_symbol
= s
;
3312 latest_undo_chgset
->syms
.safe_push (sym
);
3316 /* Given a name, find a symbol, or create it if it does not exist yet
3317 in the current namespace. If the symbol is found we make sure that
3320 The integer return code indicates
3322 1 The symbol name was ambiguous
3323 2 The name meant to be established was already host associated.
3325 So if the return value is nonzero, then an error was issued. */
3328 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3329 bool allow_subroutine
)
3334 /* This doesn't usually happen during resolution. */
3336 ns
= gfc_current_ns
;
3338 /* Try to find the symbol in ns. */
3339 st
= gfc_find_symtree (ns
->sym_root
, name
);
3341 if (st
== NULL
&& ns
->omp_udr_ns
)
3344 st
= gfc_find_symtree (ns
->sym_root
, name
);
3349 /* If not there, create a new symbol. */
3350 p
= gfc_new_symbol (name
, ns
);
3352 /* Add to the list of tentative symbols. */
3353 p
->old_symbol
= NULL
;
3356 latest_undo_chgset
->syms
.safe_push (p
);
3358 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3365 /* Make sure the existing symbol is OK. Ambiguous
3366 generic interfaces are permitted, as long as the
3367 specific interfaces are different. */
3368 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3370 ambiguous_symbol (name
, st
);
3375 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3376 && !(allow_subroutine
&& p
->attr
.subroutine
)
3377 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3378 && (ns
->has_import_set
|| p
->attr
.imported
)))
3380 /* Symbol is from another namespace. */
3381 gfc_error ("Symbol %qs at %C has already been host associated",
3388 /* Copy in case this symbol is changed. */
3389 gfc_save_symbol_data (p
);
3398 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3403 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3408 *result
= st
->n
.sym
;
3415 /* Subroutine that searches for a symbol, creating it if it doesn't
3416 exist, but tries to host-associate the symbol if possible. */
3419 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3424 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3428 gfc_save_symbol_data (st
->n
.sym
);
3433 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3443 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3448 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3453 i
= gfc_get_ha_sym_tree (name
, &st
);
3456 *result
= st
->n
.sym
;
3464 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3465 head->name as the common_root symtree's name might be mangled. */
3467 static gfc_symtree
*
3468 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3471 gfc_symtree
*result
;
3476 if (st
->n
.common
== head
)
3479 result
= find_common_symtree (st
->left
, head
);
3481 result
= find_common_symtree (st
->right
, head
);
3487 /* Clear the given storage, and make it the current change set for registering
3488 changed symbols. Its contents are freed after a call to
3489 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
3490 it is up to the caller to free the storage itself. It is usually a local
3491 variable, so there is nothing to do anyway. */
3494 gfc_new_undo_checkpoint (gfc_undo_change_set
&chg_syms
)
3496 chg_syms
.syms
= vNULL
;
3497 chg_syms
.tbps
= vNULL
;
3498 chg_syms
.previous
= latest_undo_chgset
;
3499 latest_undo_chgset
= &chg_syms
;
3503 /* Restore previous state of symbol. Just copy simple stuff. */
3506 restore_old_symbol (gfc_symbol
*p
)
3511 old
= p
->old_symbol
;
3513 p
->ts
.type
= old
->ts
.type
;
3514 p
->ts
.kind
= old
->ts
.kind
;
3516 p
->attr
= old
->attr
;
3518 if (p
->value
!= old
->value
)
3520 gcc_checking_assert (old
->value
== NULL
);
3521 gfc_free_expr (p
->value
);
3525 if (p
->as
!= old
->as
)
3528 gfc_free_array_spec (p
->as
);
3532 p
->generic
= old
->generic
;
3533 p
->component_access
= old
->component_access
;
3535 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3537 gfc_free_namelist (p
->namelist
);
3542 if (p
->namelist_tail
!= old
->namelist_tail
)
3544 gfc_free_namelist (old
->namelist_tail
->next
);
3545 old
->namelist_tail
->next
= NULL
;
3549 p
->namelist_tail
= old
->namelist_tail
;
3551 if (p
->formal
!= old
->formal
)
3553 gfc_free_formal_arglist (p
->formal
);
3554 p
->formal
= old
->formal
;
3557 set_symbol_common_block (p
, old
->common_block
);
3558 p
->common_head
= old
->common_head
;
3560 p
->old_symbol
= old
->old_symbol
;
3565 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3566 the structure itself. */
3569 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3576 /* Given a change set pointer, free its target's contents and update it with
3577 the address of the previous change set. Note that only the contents are
3578 freed, not the target itself (the contents' container). It is not a problem
3579 as the latter will be a local variable usually. */
3582 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3584 free_undo_change_set_data (*cs
);
3589 static void free_old_symbol (gfc_symbol
*sym
);
3592 /* Merges the current change set into the previous one. The changes themselves
3593 are left untouched; only one checkpoint is forgotten. */
3596 gfc_drop_last_undo_checkpoint (void)
3601 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3603 /* No need to loop in this case. */
3604 if (s
->old_symbol
== NULL
)
3607 /* Remove the duplicate symbols. */
3608 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3611 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3613 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3614 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3615 shall contain from now on the backup symbol for S as it was
3616 at the checkpoint before. */
3617 if (s
->old_symbol
->gfc_new
)
3619 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3620 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3621 free_old_symbol (s
);
3624 restore_old_symbol (s
->old_symbol
);
3629 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3630 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3632 pop_undo_change_set (latest_undo_chgset
);
3636 /* Undoes all the changes made to symbols since the previous checkpoint.
3637 This subroutine is made simpler due to the fact that attributes are
3638 never removed once added. */
3641 gfc_restore_last_undo_checkpoint (void)
3646 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3648 /* Symbol in a common block was new. Or was old and just put in common */
3650 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3652 /* If the symbol was added to any common block, it
3653 needs to be removed to stop the resolver looking
3654 for a (possibly) dead symbol. */
3655 if (p
->common_block
->head
== p
&& !p
->common_next
)
3657 gfc_symtree st
, *st0
;
3658 st0
= find_common_symtree (p
->ns
->common_root
,
3662 st
.name
= st0
->name
;
3663 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3668 if (p
->common_block
->head
== p
)
3669 p
->common_block
->head
= p
->common_next
;
3672 gfc_symbol
*cparent
, *csym
;
3674 cparent
= p
->common_block
->head
;
3675 csym
= cparent
->common_next
;
3680 csym
= csym
->common_next
;
3683 gcc_assert(cparent
->common_next
== p
);
3684 cparent
->common_next
= csym
->common_next
;
3686 p
->common_next
= NULL
;
3690 /* The derived type is saved in the symtree with the first
3691 letter capitalized; the all lower-case version to the
3692 derived type contains its associated generic function. */
3693 if (gfc_fl_struct (p
->attr
.flavor
))
3694 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3696 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3698 gfc_release_symbol (p
);
3701 restore_old_symbol (p
);
3704 latest_undo_chgset
->syms
.truncate (0);
3705 latest_undo_chgset
->tbps
.truncate (0);
3707 if (!single_undo_checkpoint_p ())
3708 pop_undo_change_set (latest_undo_chgset
);
3712 /* Makes sure that there is only one set of changes; in other words we haven't
3713 forgotten to pair a call to gfc_new_checkpoint with a call to either
3714 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3717 enforce_single_undo_checkpoint (void)
3719 gcc_checking_assert (single_undo_checkpoint_p ());
3723 /* Undoes all the changes made to symbols in the current statement. */
3726 gfc_undo_symbols (void)
3728 enforce_single_undo_checkpoint ();
3729 gfc_restore_last_undo_checkpoint ();
3733 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3734 components of old_symbol that might need deallocation are the "allocatables"
3735 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3736 namelist_tail. In case these differ between old_symbol and sym, it's just
3737 because sym->namelist has gotten a few more items. */
3740 free_old_symbol (gfc_symbol
*sym
)
3743 if (sym
->old_symbol
== NULL
)
3746 if (sym
->old_symbol
->as
!= sym
->as
)
3747 gfc_free_array_spec (sym
->old_symbol
->as
);
3749 if (sym
->old_symbol
->value
!= sym
->value
)
3750 gfc_free_expr (sym
->old_symbol
->value
);
3752 if (sym
->old_symbol
->formal
!= sym
->formal
)
3753 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3755 free (sym
->old_symbol
);
3756 sym
->old_symbol
= NULL
;
3760 /* Makes the changes made in the current statement permanent-- gets
3761 rid of undo information. */
3764 gfc_commit_symbols (void)
3767 gfc_typebound_proc
*tbp
;
3770 enforce_single_undo_checkpoint ();
3772 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3776 free_old_symbol (p
);
3778 latest_undo_chgset
->syms
.truncate (0);
3780 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3782 latest_undo_chgset
->tbps
.truncate (0);
3786 /* Makes the changes made in one symbol permanent -- gets rid of undo
3790 gfc_commit_symbol (gfc_symbol
*sym
)
3795 enforce_single_undo_checkpoint ();
3797 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3800 latest_undo_chgset
->syms
.unordered_remove (i
);
3807 free_old_symbol (sym
);
3811 /* Recursively free trees containing type-bound procedures. */
3814 free_tb_tree (gfc_symtree
*t
)
3819 free_tb_tree (t
->left
);
3820 free_tb_tree (t
->right
);
3822 /* TODO: Free type-bound procedure structs themselves; probably needs some
3823 sort of ref-counting mechanism. */
3829 /* Recursive function that deletes an entire tree and all the common
3830 head structures it points to. */
3833 free_common_tree (gfc_symtree
* common_tree
)
3835 if (common_tree
== NULL
)
3838 free_common_tree (common_tree
->left
);
3839 free_common_tree (common_tree
->right
);
3845 /* Recursive function that deletes an entire tree and all the common
3846 head structures it points to. */
3849 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3851 if (omp_udr_tree
== NULL
)
3854 free_omp_udr_tree (omp_udr_tree
->left
);
3855 free_omp_udr_tree (omp_udr_tree
->right
);
3857 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3858 free (omp_udr_tree
);
3862 /* Recursive function that deletes an entire tree and all the user
3863 operator nodes that it contains. */
3866 free_uop_tree (gfc_symtree
*uop_tree
)
3868 if (uop_tree
== NULL
)
3871 free_uop_tree (uop_tree
->left
);
3872 free_uop_tree (uop_tree
->right
);
3874 gfc_free_interface (uop_tree
->n
.uop
->op
);
3875 free (uop_tree
->n
.uop
);
3880 /* Recursive function that deletes an entire tree and all the symbols
3881 that it contains. */
3884 free_sym_tree (gfc_symtree
*sym_tree
)
3886 if (sym_tree
== NULL
)
3889 free_sym_tree (sym_tree
->left
);
3890 free_sym_tree (sym_tree
->right
);
3892 gfc_release_symbol (sym_tree
->n
.sym
);
3897 /* Free the derived type list. */
3900 gfc_free_dt_list (void)
3902 gfc_dt_list
*dt
, *n
;
3904 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3910 gfc_derived_types
= NULL
;
3914 /* Free the gfc_equiv_info's. */
3917 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3921 gfc_free_equiv_infos (s
->next
);
3926 /* Free the gfc_equiv_lists. */
3929 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3933 gfc_free_equiv_lists (l
->next
);
3934 gfc_free_equiv_infos (l
->equiv
);
3939 /* Free a finalizer procedure list. */
3942 gfc_free_finalizer (gfc_finalizer
* el
)
3946 gfc_release_symbol (el
->proc_sym
);
3952 gfc_free_finalizer_list (gfc_finalizer
* list
)
3956 gfc_finalizer
* current
= list
;
3958 gfc_free_finalizer (current
);
3963 /* Create a new gfc_charlen structure and add it to a namespace.
3964 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3967 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3971 cl
= gfc_get_charlen ();
3976 cl
->length
= gfc_copy_expr (old_cl
->length
);
3977 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3978 cl
->backend_decl
= old_cl
->backend_decl
;
3979 cl
->passed_length
= old_cl
->passed_length
;
3980 cl
->resolved
= old_cl
->resolved
;
3983 /* Put into namespace. */
3984 cl
->next
= ns
->cl_list
;
3991 /* Free the charlen list from cl to end (end is not freed).
3992 Free the whole list if end is NULL. */
3995 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3999 for (; cl
!= end
; cl
= cl2
)
4004 gfc_free_expr (cl
->length
);
4010 /* Free entry list structs. */
4013 free_entry_list (gfc_entry_list
*el
)
4015 gfc_entry_list
*next
;
4022 free_entry_list (next
);
4026 /* Free a namespace structure and everything below it. Interface
4027 lists associated with intrinsic operators are not freed. These are
4028 taken care of when a specific name is freed. */
4031 gfc_free_namespace (gfc_namespace
*ns
)
4033 gfc_namespace
*p
, *q
;
4043 gcc_assert (ns
->refs
== 0);
4045 gfc_free_statements (ns
->code
);
4047 free_sym_tree (ns
->sym_root
);
4048 free_uop_tree (ns
->uop_root
);
4049 free_common_tree (ns
->common_root
);
4050 free_omp_udr_tree (ns
->omp_udr_root
);
4051 free_tb_tree (ns
->tb_sym_root
);
4052 free_tb_tree (ns
->tb_uop_root
);
4053 gfc_free_finalizer_list (ns
->finalizers
);
4054 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
4055 gfc_free_charlen (ns
->cl_list
, NULL
);
4056 free_st_labels (ns
->st_labels
);
4058 free_entry_list (ns
->entries
);
4059 gfc_free_equiv (ns
->equiv
);
4060 gfc_free_equiv_lists (ns
->equiv_lists
);
4061 gfc_free_use_stmts (ns
->use_stmts
);
4063 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4064 gfc_free_interface (ns
->op
[i
]);
4066 gfc_free_data (ns
->data
);
4070 /* Recursively free any contained namespaces. */
4075 gfc_free_namespace (q
);
4081 gfc_symbol_init_2 (void)
4084 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
4089 gfc_symbol_done_2 (void)
4091 if (gfc_current_ns
!= NULL
)
4093 /* free everything from the root. */
4094 while (gfc_current_ns
->parent
!= NULL
)
4095 gfc_current_ns
= gfc_current_ns
->parent
;
4096 gfc_free_namespace (gfc_current_ns
);
4097 gfc_current_ns
= NULL
;
4099 gfc_free_dt_list ();
4101 enforce_single_undo_checkpoint ();
4102 free_undo_change_set_data (*latest_undo_chgset
);
4106 /* Count how many nodes a symtree has. */
4109 count_st_nodes (const gfc_symtree
*st
)
4115 nodes
= count_st_nodes (st
->left
);
4117 nodes
+= count_st_nodes (st
->right
);
4123 /* Convert symtree tree into symtree vector. */
4126 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4131 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4132 st_vec
[node_cntr
++] = st
;
4133 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4139 /* Traverse namespace. As the functions might modify the symtree, we store the
4140 symtree as a vector and operate on this vector. Note: We assume that
4141 sym_func or st_func never deletes nodes from the symtree - only adding is
4142 allowed. Additionally, newly added nodes are not traversed. */
4145 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4146 void (*sym_func
) (gfc_symbol
*))
4148 gfc_symtree
**st_vec
;
4149 unsigned nodes
, i
, node_cntr
;
4151 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4152 nodes
= count_st_nodes (st
);
4153 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4155 fill_st_vector (st
, st_vec
, node_cntr
);
4160 for (i
= 0; i
< nodes
; i
++)
4161 st_vec
[i
]->n
.sym
->mark
= 0;
4162 for (i
= 0; i
< nodes
; i
++)
4163 if (!st_vec
[i
]->n
.sym
->mark
)
4165 (*sym_func
) (st_vec
[i
]->n
.sym
);
4166 st_vec
[i
]->n
.sym
->mark
= 1;
4170 for (i
= 0; i
< nodes
; i
++)
4171 (*st_func
) (st_vec
[i
]);
4175 /* Recursively traverse the symtree nodes. */
4178 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4180 do_traverse_symtree (st
, st_func
, NULL
);
4184 /* Call a given function for all symbols in the namespace. We take
4185 care that each gfc_symbol node is called exactly once. */
4188 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4190 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4194 /* Return TRUE when name is the name of an intrinsic type. */
4197 gfc_is_intrinsic_typename (const char *name
)
4199 if (strcmp (name
, "integer") == 0
4200 || strcmp (name
, "real") == 0
4201 || strcmp (name
, "character") == 0
4202 || strcmp (name
, "logical") == 0
4203 || strcmp (name
, "complex") == 0
4204 || strcmp (name
, "doubleprecision") == 0
4205 || strcmp (name
, "doublecomplex") == 0)
4212 /* Return TRUE if the symbol is an automatic variable. */
4215 gfc_is_var_automatic (gfc_symbol
*sym
)
4217 /* Pointer and allocatable variables are never automatic. */
4218 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4220 /* Check for arrays with non-constant size. */
4221 if (sym
->attr
.dimension
&& sym
->as
4222 && !gfc_is_compile_time_shape (sym
->as
))
4224 /* Check for non-constant length character variables. */
4225 if (sym
->ts
.type
== BT_CHARACTER
4227 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4229 /* Variables with explicit AUTOMATIC attribute. */
4230 if (sym
->attr
.automatic
)
4236 /* Given a symbol, mark it as SAVEd if it is allowed. */
4239 save_symbol (gfc_symbol
*sym
)
4242 if (sym
->attr
.use_assoc
)
4245 if (sym
->attr
.in_common
4248 || sym
->attr
.flavor
!= FL_VARIABLE
)
4250 /* Automatic objects are not saved. */
4251 if (gfc_is_var_automatic (sym
))
4253 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4257 /* Mark those symbols which can be SAVEd as such. */
4260 gfc_save_all (gfc_namespace
*ns
)
4262 gfc_traverse_ns (ns
, save_symbol
);
4266 /* Make sure that no changes to symbols are pending. */
4269 gfc_enforce_clean_symbol_state(void)
4271 enforce_single_undo_checkpoint ();
4272 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4276 /************** Global symbol handling ************/
4279 /* Search a tree for the global symbol. */
4282 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4291 c
= strcmp (name
, symbol
->name
);
4295 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4302 /* Case insensitive search a tree for the global symbol. */
4305 gfc_find_case_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4314 c
= strcasecmp (name
, symbol
->name
);
4318 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4325 /* Compare two global symbols. Used for managing the BB tree. */
4328 gsym_compare (void *_s1
, void *_s2
)
4330 gfc_gsymbol
*s1
, *s2
;
4332 s1
= (gfc_gsymbol
*) _s1
;
4333 s2
= (gfc_gsymbol
*) _s2
;
4334 return strcmp (s1
->name
, s2
->name
);
4338 /* Get a global symbol, creating it if it doesn't exist. */
4341 gfc_get_gsymbol (const char *name
)
4345 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4349 s
= XCNEW (gfc_gsymbol
);
4350 s
->type
= GSYM_UNKNOWN
;
4351 s
->name
= gfc_get_string ("%s", name
);
4353 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4360 get_iso_c_binding_dt (int sym_id
)
4362 gfc_dt_list
*dt_list
;
4364 dt_list
= gfc_derived_types
;
4366 /* Loop through the derived types in the name list, searching for
4367 the desired symbol from iso_c_binding. Search the parent namespaces
4368 if necessary and requested to (parent_flag). */
4369 while (dt_list
!= NULL
)
4371 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
4372 && dt_list
->derived
->intmod_sym_id
== sym_id
)
4373 return dt_list
->derived
;
4375 dt_list
= dt_list
->next
;
4382 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4383 with C. This is necessary for any derived type that is BIND(C) and for
4384 derived types that are parameters to functions that are BIND(C). All
4385 fields of the derived type are required to be interoperable, and are tested
4386 for such. If an error occurs, the errors are reported here, allowing for
4387 multiple errors to be handled for a single derived type. */
4390 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4392 gfc_component
*curr_comp
= NULL
;
4393 bool is_c_interop
= false;
4396 if (derived_sym
== NULL
)
4397 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4398 "unexpectedly NULL");
4400 /* If we've already looked at this derived symbol, do not look at it again
4401 so we don't repeat warnings/errors. */
4402 if (derived_sym
->ts
.is_c_interop
)
4405 /* The derived type must have the BIND attribute to be interoperable
4406 J3/04-007, Section 15.2.3. */
4407 if (derived_sym
->attr
.is_bind_c
!= 1)
4409 derived_sym
->ts
.is_c_interop
= 0;
4410 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4411 "attribute to be C interoperable", derived_sym
->name
,
4412 &(derived_sym
->declared_at
));
4416 curr_comp
= derived_sym
->components
;
4418 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4419 empty struct. Section 15.2 in Fortran 2003 states: "The following
4420 subclauses define the conditions under which a Fortran entity is
4421 interoperable. If a Fortran entity is interoperable, an equivalent
4422 entity may be defined by means of C and the Fortran entity is said
4423 to be interoperable with the C entity. There does not have to be such
4424 an interoperating C entity."
4426 if (curr_comp
== NULL
)
4428 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4429 "and may be inaccessible by the C companion processor",
4430 derived_sym
->name
, &(derived_sym
->declared_at
));
4431 derived_sym
->ts
.is_c_interop
= 1;
4432 derived_sym
->attr
.is_bind_c
= 1;
4437 /* Initialize the derived type as being C interoperable.
4438 If we find an error in the components, this will be set false. */
4439 derived_sym
->ts
.is_c_interop
= 1;
4441 /* Loop through the list of components to verify that the kind of
4442 each is a C interoperable type. */
4445 /* The components cannot be pointers (fortran sense).
4446 J3/04-007, Section 15.2.3, C1505. */
4447 if (curr_comp
->attr
.pointer
!= 0)
4449 gfc_error ("Component %qs at %L cannot have the "
4450 "POINTER attribute because it is a member "
4451 "of the BIND(C) derived type %qs at %L",
4452 curr_comp
->name
, &(curr_comp
->loc
),
4453 derived_sym
->name
, &(derived_sym
->declared_at
));
4457 if (curr_comp
->attr
.proc_pointer
!= 0)
4459 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4460 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4461 &curr_comp
->loc
, derived_sym
->name
,
4462 &derived_sym
->declared_at
);
4466 /* The components cannot be allocatable.
4467 J3/04-007, Section 15.2.3, C1505. */
4468 if (curr_comp
->attr
.allocatable
!= 0)
4470 gfc_error ("Component %qs at %L cannot have the "
4471 "ALLOCATABLE attribute because it is a member "
4472 "of the BIND(C) derived type %qs at %L",
4473 curr_comp
->name
, &(curr_comp
->loc
),
4474 derived_sym
->name
, &(derived_sym
->declared_at
));
4478 /* BIND(C) derived types must have interoperable components. */
4479 if (curr_comp
->ts
.type
== BT_DERIVED
4480 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4481 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4483 /* This should be allowed; the draft says a derived-type can not
4484 have type parameters if it is has the BIND attribute. Type
4485 parameters seem to be for making parameterized derived types.
4486 There's no need to verify the type if it is c_ptr/c_funptr. */
4487 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4491 /* Grab the typespec for the given component and test the kind. */
4492 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4496 /* Report warning and continue since not fatal. The
4497 draft does specify a constraint that requires all fields
4498 to interoperate, but if the user says real(4), etc., it
4499 may interoperate with *something* in C, but the compiler
4500 most likely won't know exactly what. Further, it may not
4501 interoperate with the same data type(s) in C if the user
4502 recompiles with different flags (e.g., -m32 and -m64 on
4503 x86_64 and using integer(4) to claim interop with a
4505 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4506 /* If the derived type is bind(c), all fields must be
4508 gfc_warning (OPT_Wc_binding_type
,
4509 "Component %qs in derived type %qs at %L "
4510 "may not be C interoperable, even though "
4511 "derived type %qs is BIND(C)",
4512 curr_comp
->name
, derived_sym
->name
,
4513 &(curr_comp
->loc
), derived_sym
->name
);
4514 else if (warn_c_binding_type
)
4515 /* If derived type is param to bind(c) routine, or to one
4516 of the iso_c_binding procs, it must be interoperable, so
4517 all fields must interop too. */
4518 gfc_warning (OPT_Wc_binding_type
,
4519 "Component %qs in derived type %qs at %L "
4520 "may not be C interoperable",
4521 curr_comp
->name
, derived_sym
->name
,
4526 curr_comp
= curr_comp
->next
;
4527 } while (curr_comp
!= NULL
);
4530 /* Make sure we don't have conflicts with the attributes. */
4531 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
4533 gfc_error ("Derived type %qs at %L cannot be declared with both "
4534 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
4535 &(derived_sym
->declared_at
));
4539 if (derived_sym
->attr
.sequence
!= 0)
4541 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4542 "attribute because it is BIND(C)", derived_sym
->name
,
4543 &(derived_sym
->declared_at
));
4547 /* Mark the derived type as not being C interoperable if we found an
4548 error. If there were only warnings, proceed with the assumption
4549 it's interoperable. */
4551 derived_sym
->ts
.is_c_interop
= 0;
4557 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4560 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4564 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4565 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4567 tmp_sym
->attr
.is_c_interop
= 1;
4568 tmp_sym
->attr
.is_bind_c
= 1;
4569 tmp_sym
->ts
.is_c_interop
= 1;
4570 tmp_sym
->ts
.is_iso_c
= 1;
4571 tmp_sym
->ts
.type
= BT_DERIVED
;
4572 tmp_sym
->ts
.f90_type
= BT_VOID
;
4573 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4574 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4576 /* Set the c_address field of c_null_ptr and c_null_funptr to
4577 the value of NULL. */
4578 tmp_sym
->value
= gfc_get_expr ();
4579 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4580 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4581 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4582 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4583 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4584 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4585 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4586 c
->expr
->ts
.is_iso_c
= 1;
4592 /* Add a formal argument, gfc_formal_arglist, to the
4593 end of the given list of arguments. Set the reference to the
4594 provided symbol, param_sym, in the argument. */
4597 add_formal_arg (gfc_formal_arglist
**head
,
4598 gfc_formal_arglist
**tail
,
4599 gfc_formal_arglist
*formal_arg
,
4600 gfc_symbol
*param_sym
)
4602 /* Put in list, either as first arg or at the tail (curr arg). */
4604 *head
= *tail
= formal_arg
;
4607 (*tail
)->next
= formal_arg
;
4608 (*tail
) = formal_arg
;
4611 (*tail
)->sym
= param_sym
;
4612 (*tail
)->next
= NULL
;
4618 /* Add a procedure interface to the given symbol (i.e., store a
4619 reference to the list of formal arguments). */
4622 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4625 sym
->formal
= formal
;
4626 sym
->attr
.if_source
= source
;
4630 /* Copy the formal args from an existing symbol, src, into a new
4631 symbol, dest. New formal args are created, and the description of
4632 each arg is set according to the existing ones. This function is
4633 used when creating procedure declaration variables from a procedure
4634 declaration statement (see match_proc_decl()) to create the formal
4635 args based on the args of a given named interface.
4637 When an actual argument list is provided, skip the absent arguments.
4638 To be used together with gfc_se->ignore_optional. */
4641 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4642 gfc_actual_arglist
*actual
)
4644 gfc_formal_arglist
*head
= NULL
;
4645 gfc_formal_arglist
*tail
= NULL
;
4646 gfc_formal_arglist
*formal_arg
= NULL
;
4647 gfc_intrinsic_arg
*curr_arg
= NULL
;
4648 gfc_formal_arglist
*formal_prev
= NULL
;
4649 gfc_actual_arglist
*act_arg
= actual
;
4650 /* Save current namespace so we can change it for formal args. */
4651 gfc_namespace
*parent_ns
= gfc_current_ns
;
4653 /* Create a new namespace, which will be the formal ns (namespace
4654 of the formal args). */
4655 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4656 gfc_current_ns
->proc_name
= dest
;
4658 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4660 /* Skip absent arguments. */
4663 gcc_assert (act_arg
!= NULL
);
4664 if (act_arg
->expr
== NULL
)
4666 act_arg
= act_arg
->next
;
4669 act_arg
= act_arg
->next
;
4671 formal_arg
= gfc_get_formal_arglist ();
4672 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4674 /* May need to copy more info for the symbol. */
4675 formal_arg
->sym
->ts
= curr_arg
->ts
;
4676 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4677 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4678 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4679 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4680 formal_arg
->sym
->attr
.dummy
= 1;
4682 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4683 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4685 /* If this isn't the first arg, set up the next ptr. For the
4686 last arg built, the formal_arg->next will never get set to
4687 anything other than NULL. */
4688 if (formal_prev
!= NULL
)
4689 formal_prev
->next
= formal_arg
;
4691 formal_arg
->next
= NULL
;
4693 formal_prev
= formal_arg
;
4695 /* Add arg to list of formal args. */
4696 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4698 /* Validate changes. */
4699 gfc_commit_symbol (formal_arg
->sym
);
4702 /* Add the interface to the symbol. */
4703 add_proc_interface (dest
, IFSRC_DECL
, head
);
4705 /* Store the formal namespace information. */
4706 if (dest
->formal
!= NULL
)
4707 /* The current ns should be that for the dest proc. */
4708 dest
->formal_ns
= gfc_current_ns
;
4709 /* Restore the current namespace to what it was on entry. */
4710 gfc_current_ns
= parent_ns
;
4715 std_for_isocbinding_symbol (int id
)
4719 #define NAMED_INTCST(a,b,c,d) \
4722 #include "iso-c-binding.def"
4725 #define NAMED_FUNCTION(a,b,c,d) \
4728 #define NAMED_SUBROUTINE(a,b,c,d) \
4731 #include "iso-c-binding.def"
4732 #undef NAMED_FUNCTION
4733 #undef NAMED_SUBROUTINE
4736 return GFC_STD_F2003
;
4740 /* Generate the given set of C interoperable kind objects, or all
4741 interoperable kinds. This function will only be given kind objects
4742 for valid iso_c_binding defined types because this is verified when
4743 the 'use' statement is parsed. If the user gives an 'only' clause,
4744 the specific kinds are looked up; if they don't exist, an error is
4745 reported. If the user does not give an 'only' clause, all
4746 iso_c_binding symbols are generated. If a list of specific kinds
4747 is given, it must have a NULL in the first empty spot to mark the
4748 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4749 point to the symtree for c_(fun)ptr. */
4752 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4753 const char *local_name
, gfc_symtree
*dt_symtree
,
4756 const char *const name
= (local_name
&& local_name
[0])
4757 ? local_name
: c_interop_kinds_table
[s
].name
;
4758 gfc_symtree
*tmp_symtree
;
4759 gfc_symbol
*tmp_sym
= NULL
;
4762 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4765 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4767 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4768 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4769 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4772 /* Already exists in this scope so don't re-add it. */
4773 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4774 && (!tmp_sym
->attr
.generic
4775 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4776 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4778 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4779 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4781 gfc_dt_list
*dt_list
;
4782 dt_list
= gfc_get_dt_list ();
4783 dt_list
->derived
= tmp_sym
;
4784 dt_list
->next
= gfc_derived_types
;
4785 gfc_derived_types
= dt_list
;
4791 /* Create the sym tree in the current ns. */
4794 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4795 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4797 /* Add to the list of tentative symbols. */
4798 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4799 tmp_sym
->old_symbol
= NULL
;
4801 tmp_sym
->gfc_new
= 1;
4803 tmp_symtree
->n
.sym
= tmp_sym
;
4808 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4809 gcc_assert (tmp_symtree
);
4810 tmp_sym
= tmp_symtree
->n
.sym
;
4813 /* Say what module this symbol belongs to. */
4814 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4815 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4816 tmp_sym
->intmod_sym_id
= s
;
4817 tmp_sym
->attr
.is_iso_c
= 1;
4818 tmp_sym
->attr
.use_assoc
= 1;
4820 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4821 || s
== ISOCBINDING_NULL_PTR
);
4826 #define NAMED_INTCST(a,b,c,d) case a :
4827 #define NAMED_REALCST(a,b,c,d) case a :
4828 #define NAMED_CMPXCST(a,b,c,d) case a :
4829 #define NAMED_LOGCST(a,b,c) case a :
4830 #define NAMED_CHARKNDCST(a,b,c) case a :
4831 #include "iso-c-binding.def"
4833 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4834 c_interop_kinds_table
[s
].value
);
4836 /* Initialize an integer constant expression node. */
4837 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4838 tmp_sym
->ts
.type
= BT_INTEGER
;
4839 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4841 /* Mark this type as a C interoperable one. */
4842 tmp_sym
->ts
.is_c_interop
= 1;
4843 tmp_sym
->ts
.is_iso_c
= 1;
4844 tmp_sym
->value
->ts
.is_c_interop
= 1;
4845 tmp_sym
->value
->ts
.is_iso_c
= 1;
4846 tmp_sym
->attr
.is_c_interop
= 1;
4848 /* Tell what f90 type this c interop kind is valid. */
4849 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4854 #define NAMED_CHARCST(a,b,c) case a :
4855 #include "iso-c-binding.def"
4857 /* Initialize an integer constant expression node for the
4858 length of the character. */
4859 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4860 &gfc_current_locus
, NULL
, 1);
4861 tmp_sym
->value
->ts
.is_c_interop
= 1;
4862 tmp_sym
->value
->ts
.is_iso_c
= 1;
4863 tmp_sym
->value
->value
.character
.length
= 1;
4864 tmp_sym
->value
->value
.character
.string
[0]
4865 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4866 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4867 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4870 /* May not need this in both attr and ts, but do need in
4871 attr for writing module file. */
4872 tmp_sym
->attr
.is_c_interop
= 1;
4874 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4875 tmp_sym
->ts
.type
= BT_CHARACTER
;
4877 /* Need to set it to the C_CHAR kind. */
4878 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4880 /* Mark this type as a C interoperable one. */
4881 tmp_sym
->ts
.is_c_interop
= 1;
4882 tmp_sym
->ts
.is_iso_c
= 1;
4884 /* Tell what f90 type this c interop kind is valid. */
4885 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4889 case ISOCBINDING_PTR
:
4890 case ISOCBINDING_FUNPTR
:
4893 gfc_dt_list
**dt_list_ptr
= NULL
;
4894 gfc_component
*tmp_comp
= NULL
;
4896 /* Generate real derived type. */
4901 const char *hidden_name
;
4902 gfc_interface
*intr
, *head
;
4904 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4905 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4907 gcc_assert (tmp_symtree
== NULL
);
4908 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4909 dt_sym
= tmp_symtree
->n
.sym
;
4910 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4911 ? "c_ptr" : "c_funptr");
4913 /* Generate an artificial generic function. */
4914 head
= tmp_sym
->generic
;
4915 intr
= gfc_get_interface ();
4917 intr
->where
= gfc_current_locus
;
4919 tmp_sym
->generic
= intr
;
4921 if (!tmp_sym
->attr
.generic
4922 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4925 if (!tmp_sym
->attr
.function
4926 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4930 /* Say what module this symbol belongs to. */
4931 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4932 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4933 dt_sym
->intmod_sym_id
= s
;
4934 dt_sym
->attr
.use_assoc
= 1;
4936 /* Initialize an integer constant expression node. */
4937 dt_sym
->attr
.flavor
= FL_DERIVED
;
4938 dt_sym
->ts
.is_c_interop
= 1;
4939 dt_sym
->attr
.is_c_interop
= 1;
4940 dt_sym
->attr
.private_comp
= 1;
4941 dt_sym
->component_access
= ACCESS_PRIVATE
;
4942 dt_sym
->ts
.is_iso_c
= 1;
4943 dt_sym
->ts
.type
= BT_DERIVED
;
4944 dt_sym
->ts
.f90_type
= BT_VOID
;
4946 /* A derived type must have the bind attribute to be
4947 interoperable (J3/04-007, Section 15.2.3), even though
4948 the binding label is not used. */
4949 dt_sym
->attr
.is_bind_c
= 1;
4951 dt_sym
->attr
.referenced
= 1;
4952 dt_sym
->ts
.u
.derived
= dt_sym
;
4954 /* Add the symbol created for the derived type to the current ns. */
4955 dt_list_ptr
= &(gfc_derived_types
);
4956 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4957 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4959 /* There is already at least one derived type in the list, so append
4960 the one we're currently building for c_ptr or c_funptr. */
4961 if (*dt_list_ptr
!= NULL
)
4962 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4963 (*dt_list_ptr
) = gfc_get_dt_list ();
4964 (*dt_list_ptr
)->derived
= dt_sym
;
4965 (*dt_list_ptr
)->next
= NULL
;
4967 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4968 if (tmp_comp
== NULL
)
4971 tmp_comp
->ts
.type
= BT_INTEGER
;
4973 /* Set this because the module will need to read/write this field. */
4974 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4976 /* The kinds for c_ptr and c_funptr are the same. */
4977 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4978 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4979 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4981 /* Mark the component as C interoperable. */
4982 tmp_comp
->ts
.is_c_interop
= 1;
4987 case ISOCBINDING_NULL_PTR
:
4988 case ISOCBINDING_NULL_FUNPTR
:
4989 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4995 gfc_commit_symbol (tmp_sym
);
5000 /* Check that a symbol is already typed. If strict is not set, an untyped
5001 symbol is acceptable for non-standard-conforming mode. */
5004 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
5005 bool strict
, locus where
)
5009 if (gfc_matching_prefix
)
5012 /* Check for the type and try to give it an implicit one. */
5013 if (sym
->ts
.type
== BT_UNKNOWN
5014 && !gfc_set_default_type (sym
, 0, ns
))
5018 gfc_error ("Symbol %qs is used before it is typed at %L",
5023 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
5024 " it is typed at %L", sym
->name
, &where
))
5028 /* Everything is ok. */
5033 /* Construct a typebound-procedure structure. Those are stored in a tentative
5034 list and marked `error' until symbols are committed. */
5037 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
5039 gfc_typebound_proc
*result
;
5041 result
= XCNEW (gfc_typebound_proc
);
5046 latest_undo_chgset
->tbps
.safe_push (result
);
5052 /* Get the super-type of a given derived type. */
5055 gfc_get_derived_super_type (gfc_symbol
* derived
)
5057 gcc_assert (derived
);
5059 if (derived
->attr
.generic
)
5060 derived
= gfc_find_dt_in_generic (derived
);
5062 if (!derived
->attr
.extension
)
5065 gcc_assert (derived
->components
);
5066 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
5067 gcc_assert (derived
->components
->ts
.u
.derived
);
5069 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
5070 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
5072 return derived
->components
->ts
.u
.derived
;
5076 /* Get the ultimate super-type of a given derived type. */
5079 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
5081 if (!derived
->attr
.extension
)
5084 derived
= gfc_get_derived_super_type (derived
);
5086 if (derived
->attr
.extension
)
5087 return gfc_get_ultimate_derived_super_type (derived
);
5093 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5096 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
5098 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
5099 t2
= gfc_get_derived_super_type (t2
);
5100 return gfc_compare_derived_types (t1
, t2
);
5104 /* Check if two typespecs are type compatible (F03:5.1.1.2):
5105 If ts1 is nonpolymorphic, ts2 must be the same type.
5106 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5109 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
5111 bool is_class1
= (ts1
->type
== BT_CLASS
);
5112 bool is_class2
= (ts2
->type
== BT_CLASS
);
5113 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
5114 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
5115 bool is_union1
= (ts1
->type
== BT_UNION
);
5116 bool is_union2
= (ts2
->type
== BT_UNION
);
5119 && ts1
->u
.derived
->components
5120 && ((ts1
->u
.derived
->attr
.is_class
5121 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
5122 .unlimited_polymorphic
)
5123 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
5126 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5127 && !is_union1
&& !is_union2
)
5128 return (ts1
->type
== ts2
->type
);
5130 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5131 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5133 if (is_derived1
&& is_class2
)
5134 return gfc_compare_derived_types (ts1
->u
.derived
,
5135 ts2
->u
.derived
->attr
.is_class
?
5136 ts2
->u
.derived
->components
->ts
.u
.derived
5138 if (is_class1
&& is_derived2
)
5139 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5140 ts1
->u
.derived
->components
->ts
.u
.derived
5143 else if (is_class1
&& is_class2
)
5144 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5145 ts1
->u
.derived
->components
->ts
.u
.derived
5147 ts2
->u
.derived
->attr
.is_class
?
5148 ts2
->u
.derived
->components
->ts
.u
.derived
5155 /* Find the parent-namespace of the current function. If we're inside
5156 BLOCK constructs, it may not be the current one. */
5159 gfc_find_proc_namespace (gfc_namespace
* ns
)
5161 while (ns
->construct_entities
)
5171 /* Check if an associate-variable should be translated as an `implicit' pointer
5172 internally (if it is associated to a variable and not an array with
5176 gfc_is_associate_pointer (gfc_symbol
* sym
)
5181 if (sym
->ts
.type
== BT_CLASS
)
5184 if (sym
->ts
.type
== BT_CHARACTER
5186 && sym
->assoc
->target
5187 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5190 if (!sym
->assoc
->variable
)
5193 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5201 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5203 gfc_interface
*intr
= NULL
;
5205 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5208 if (sym
->attr
.generic
)
5209 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5210 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5212 return intr
? intr
->sym
: NULL
;
5216 /* Get the dummy arguments from a procedure symbol. If it has been declared
5217 via a PROCEDURE statement with a named interface, ts.interface will be set
5218 and the arguments need to be taken from there. */
5220 gfc_formal_arglist
*
5221 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5223 gfc_formal_arglist
*dummies
;
5225 dummies
= sym
->formal
;
5226 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5227 dummies
= sym
->ts
.interface
->formal
;