1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2017 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 /* Given a pointer to a symbol, set its type according to the first
249 letter of its name. Fails if the letter in question has no default
253 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
257 if (sym
->ts
.type
!= BT_UNKNOWN
)
258 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
260 ts
= gfc_get_default_type (sym
->name
, ns
);
262 if (ts
->type
== BT_UNKNOWN
)
264 if (error_flag
&& !sym
->attr
.untyped
)
266 gfc_error ("Symbol %qs at %L has no IMPLICIT type",
267 sym
->name
, &sym
->declared_at
);
268 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
275 sym
->attr
.implicit_type
= 1;
277 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
278 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
279 else if (ts
->type
== BT_CLASS
280 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
283 if (sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
285 /* BIND(C) variables should not be implicitly declared. */
286 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared BIND(C) "
287 "variable %qs at %L may not be C interoperable",
288 sym
->name
, &sym
->declared_at
);
289 sym
->ts
.f90_type
= sym
->ts
.type
;
292 if (sym
->attr
.dummy
!= 0)
294 if (sym
->ns
->proc_name
!= NULL
295 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
296 || sym
->ns
->proc_name
->attr
.function
!= 0)
297 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0
298 && warn_c_binding_type
)
300 /* Dummy args to a BIND(C) routine may not be interoperable if
301 they are implicitly typed. */
302 gfc_warning_now (OPT_Wc_binding_type
, "Implicitly declared variable "
303 "%qs at %L may not be C interoperable but it is a "
304 "dummy argument to the BIND(C) procedure %qs at %L",
305 sym
->name
, &(sym
->declared_at
),
306 sym
->ns
->proc_name
->name
,
307 &(sym
->ns
->proc_name
->declared_at
));
308 sym
->ts
.f90_type
= sym
->ts
.type
;
316 /* This function is called from parse.c(parse_progunit) to check the
317 type of the function is not implicitly typed in the host namespace
318 and to implicitly type the function result, if necessary. */
321 gfc_check_function_type (gfc_namespace
*ns
)
323 gfc_symbol
*proc
= ns
->proc_name
;
325 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
328 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
330 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
))
332 if (proc
->result
!= proc
)
334 proc
->ts
= proc
->result
->ts
;
335 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
336 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
337 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
338 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
341 else if (!proc
->result
->attr
.proc_pointer
)
343 gfc_error ("Function result %qs at %L has no IMPLICIT type",
344 proc
->result
->name
, &proc
->result
->declared_at
);
345 proc
->result
->attr
.untyped
= 1;
351 /******************** Symbol attribute stuff *********************/
353 /* This is a generic conflict-checker. We do this to avoid having a
354 single conflict in two places. */
356 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
357 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
358 #define conf_std(a, b, std) if (attr->a && attr->b)\
367 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
369 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
370 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
371 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
372 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
373 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
374 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
375 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
376 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
377 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
378 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
379 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
380 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
381 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
382 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
383 *proc_pointer
= "PROCEDURE POINTER", *abstract
= "ABSTRACT",
384 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
385 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC", *automatic
= "AUTOMATIC";
386 static const char *threadprivate
= "THREADPRIVATE";
387 static const char *omp_declare_target
= "OMP DECLARE TARGET";
388 static const char *omp_declare_target_link
= "OMP DECLARE TARGET LINK";
389 static const char *oacc_declare_copyin
= "OACC DECLARE COPYIN";
390 static const char *oacc_declare_create
= "OACC DECLARE CREATE";
391 static const char *oacc_declare_deviceptr
= "OACC DECLARE DEVICEPTR";
392 static const char *oacc_declare_device_resident
=
393 "OACC DECLARE DEVICE_RESIDENT";
399 where
= &gfc_current_locus
;
401 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
405 standard
= GFC_STD_F2003
;
409 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
412 a2
= attr
->allocatable
? allocatable
: pointer
;
413 standard
= GFC_STD_F2003
;
417 /* Check for attributes not allowed in a BLOCK DATA. */
418 if (gfc_current_state () == COMP_BLOCK_DATA
)
422 if (attr
->in_namelist
)
424 if (attr
->allocatable
)
430 if (attr
->access
== ACCESS_PRIVATE
)
432 if (attr
->access
== ACCESS_PUBLIC
)
434 if (attr
->intent
!= INTENT_UNKNOWN
)
440 ("%s attribute not allowed in BLOCK DATA program unit at %L",
446 if (attr
->save
== SAVE_EXPLICIT
)
449 conf (in_common
, save
);
451 conf (automatic
, save
);
453 switch (attr
->flavor
)
461 a1
= gfc_code2string (flavors
, attr
->flavor
);
465 gfc_error ("Namelist group name at %L cannot have the "
466 "SAVE attribute", where
);
469 /* Conflicts between SAVE and PROCEDURE will be checked at
470 resolution stage, see "resolve_fl_procedure". */
477 /* The copying of procedure dummy arguments for module procedures in
478 a submodule occur whilst the current state is COMP_CONTAINS. It
479 is necessary, therefore, to let this through. */
481 && (attr
->function
|| attr
->subroutine
)
482 && gfc_current_state () == COMP_CONTAINS
483 && !(gfc_new_block
&& gfc_new_block
->abr_modproc_decl
))
484 gfc_error_now ("internal procedure %qs at %L conflicts with "
485 "DUMMY argument", name
, where
);
488 conf (dummy
, intrinsic
);
489 conf (dummy
, threadprivate
);
490 conf (dummy
, omp_declare_target
);
491 conf (dummy
, omp_declare_target_link
);
492 conf (pointer
, target
);
493 conf (pointer
, intrinsic
);
494 conf (pointer
, elemental
);
495 conf (pointer
, codimension
);
496 conf (allocatable
, elemental
);
498 conf (in_common
, automatic
);
499 conf (in_equivalence
, automatic
);
500 conf (result
, automatic
);
501 conf (use_assoc
, automatic
);
502 conf (dummy
, automatic
);
504 conf (target
, external
);
505 conf (target
, intrinsic
);
507 if (!attr
->if_source
)
508 conf (external
, dimension
); /* See Fortran 95's R504. */
510 conf (external
, intrinsic
);
511 conf (entry
, intrinsic
);
513 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
514 conf (external
, subroutine
);
516 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
517 "Procedure pointer at %C"))
520 conf (allocatable
, pointer
);
521 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
522 conf_std (allocatable
, function
, GFC_STD_F2003
);
523 conf_std (allocatable
, result
, GFC_STD_F2003
);
524 conf (elemental
, recursive
);
526 conf (in_common
, dummy
);
527 conf (in_common
, allocatable
);
528 conf (in_common
, codimension
);
529 conf (in_common
, result
);
531 conf (in_equivalence
, use_assoc
);
532 conf (in_equivalence
, codimension
);
533 conf (in_equivalence
, dummy
);
534 conf (in_equivalence
, target
);
535 conf (in_equivalence
, pointer
);
536 conf (in_equivalence
, function
);
537 conf (in_equivalence
, result
);
538 conf (in_equivalence
, entry
);
539 conf (in_equivalence
, allocatable
);
540 conf (in_equivalence
, threadprivate
);
541 conf (in_equivalence
, omp_declare_target
);
542 conf (in_equivalence
, omp_declare_target_link
);
543 conf (in_equivalence
, oacc_declare_create
);
544 conf (in_equivalence
, oacc_declare_copyin
);
545 conf (in_equivalence
, oacc_declare_deviceptr
);
546 conf (in_equivalence
, oacc_declare_device_resident
);
547 conf (in_equivalence
, is_bind_c
);
549 conf (dummy
, result
);
550 conf (entry
, result
);
551 conf (generic
, result
);
552 conf (generic
, omp_declare_target
);
553 conf (generic
, omp_declare_target_link
);
555 conf (function
, subroutine
);
557 if (!function
&& !subroutine
)
558 conf (is_bind_c
, dummy
);
560 conf (is_bind_c
, cray_pointer
);
561 conf (is_bind_c
, cray_pointee
);
562 conf (is_bind_c
, codimension
);
563 conf (is_bind_c
, allocatable
);
564 conf (is_bind_c
, elemental
);
566 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
567 Parameter conflict caught below. Also, value cannot be specified
568 for a dummy procedure. */
570 /* Cray pointer/pointee conflicts. */
571 conf (cray_pointer
, cray_pointee
);
572 conf (cray_pointer
, dimension
);
573 conf (cray_pointer
, codimension
);
574 conf (cray_pointer
, contiguous
);
575 conf (cray_pointer
, pointer
);
576 conf (cray_pointer
, target
);
577 conf (cray_pointer
, allocatable
);
578 conf (cray_pointer
, external
);
579 conf (cray_pointer
, intrinsic
);
580 conf (cray_pointer
, in_namelist
);
581 conf (cray_pointer
, function
);
582 conf (cray_pointer
, subroutine
);
583 conf (cray_pointer
, entry
);
585 conf (cray_pointee
, allocatable
);
586 conf (cray_pointee
, contiguous
);
587 conf (cray_pointee
, codimension
);
588 conf (cray_pointee
, intent
);
589 conf (cray_pointee
, optional
);
590 conf (cray_pointee
, dummy
);
591 conf (cray_pointee
, target
);
592 conf (cray_pointee
, intrinsic
);
593 conf (cray_pointee
, pointer
);
594 conf (cray_pointee
, entry
);
595 conf (cray_pointee
, in_common
);
596 conf (cray_pointee
, in_equivalence
);
597 conf (cray_pointee
, threadprivate
);
598 conf (cray_pointee
, omp_declare_target
);
599 conf (cray_pointee
, omp_declare_target_link
);
600 conf (cray_pointee
, oacc_declare_create
);
601 conf (cray_pointee
, oacc_declare_copyin
);
602 conf (cray_pointee
, oacc_declare_deviceptr
);
603 conf (cray_pointee
, oacc_declare_device_resident
);
606 conf (data
, function
);
608 conf (data
, allocatable
);
610 conf (value
, pointer
)
611 conf (value
, allocatable
)
612 conf (value
, subroutine
)
613 conf (value
, function
)
614 conf (value
, volatile_
)
615 conf (value
, dimension
)
616 conf (value
, codimension
)
617 conf (value
, external
)
619 conf (codimension
, result
)
622 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
625 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
629 conf (is_protected
, intrinsic
)
630 conf (is_protected
, in_common
)
632 conf (asynchronous
, intrinsic
)
633 conf (asynchronous
, external
)
635 conf (volatile_
, intrinsic
)
636 conf (volatile_
, external
)
638 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
645 conf (procedure
, allocatable
)
646 conf (procedure
, dimension
)
647 conf (procedure
, codimension
)
648 conf (procedure
, intrinsic
)
649 conf (procedure
, target
)
650 conf (procedure
, value
)
651 conf (procedure
, volatile_
)
652 conf (procedure
, asynchronous
)
653 conf (procedure
, entry
)
655 conf (proc_pointer
, abstract
)
656 conf (proc_pointer
, omp_declare_target
)
657 conf (proc_pointer
, omp_declare_target_link
)
659 conf (entry
, omp_declare_target
)
660 conf (entry
, omp_declare_target_link
)
661 conf (entry
, oacc_declare_create
)
662 conf (entry
, oacc_declare_copyin
)
663 conf (entry
, oacc_declare_deviceptr
)
664 conf (entry
, oacc_declare_device_resident
)
666 a1
= gfc_code2string (flavors
, attr
->flavor
);
668 if (attr
->in_namelist
669 && attr
->flavor
!= FL_VARIABLE
670 && attr
->flavor
!= FL_PROCEDURE
671 && attr
->flavor
!= FL_UNKNOWN
)
677 switch (attr
->flavor
)
687 conf2 (asynchronous
);
690 conf2 (is_protected
);
700 conf2 (threadprivate
);
701 conf2 (omp_declare_target
);
702 conf2 (omp_declare_target_link
);
703 conf2 (oacc_declare_create
);
704 conf2 (oacc_declare_copyin
);
705 conf2 (oacc_declare_deviceptr
);
706 conf2 (oacc_declare_device_resident
);
708 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
710 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
711 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
718 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
732 /* Conflicts with INTENT, SAVE and RESULT will be checked
733 at resolution stage, see "resolve_fl_procedure". */
735 if (attr
->subroutine
)
741 conf2 (asynchronous
);
746 if (!attr
->proc_pointer
)
747 conf2 (threadprivate
);
750 if (!attr
->proc_pointer
)
753 conf2 (omp_declare_target_link
);
757 case PROC_ST_FUNCTION
:
768 conf2 (threadprivate
);
788 conf2 (threadprivate
);
790 conf2 (omp_declare_target
);
791 conf2 (omp_declare_target_link
);
792 conf2 (oacc_declare_create
);
793 conf2 (oacc_declare_copyin
);
794 conf2 (oacc_declare_deviceptr
);
795 conf2 (oacc_declare_device_resident
);
797 if (attr
->intent
!= INTENT_UNKNOWN
)
814 conf2 (is_protected
);
820 conf2 (asynchronous
);
821 conf2 (threadprivate
);
837 gfc_error ("%s attribute conflicts with %s attribute at %L",
840 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
841 a1
, a2
, name
, where
);
848 return gfc_notify_std (standard
, "%s attribute conflicts "
849 "with %s attribute at %L", a1
, a2
,
854 return gfc_notify_std (standard
, "%s attribute conflicts "
855 "with %s attribute in %qs at %L",
856 a1
, a2
, name
, where
);
865 /* Mark a symbol as referenced. */
868 gfc_set_sym_referenced (gfc_symbol
*sym
)
871 if (sym
->attr
.referenced
)
874 sym
->attr
.referenced
= 1;
876 /* Remember which order dummy variables are accessed in. */
878 sym
->dummy_order
= next_dummy_order
++;
882 /* Common subroutine called by attribute changing subroutines in order
883 to prevent them from changing a symbol that has been
884 use-associated. Returns zero if it is OK to change the symbol,
888 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
891 if (attr
->use_assoc
== 0)
895 where
= &gfc_current_locus
;
898 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
901 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
908 /* Generate an error because of a duplicate attribute. */
911 duplicate_attr (const char *attr
, locus
*where
)
915 where
= &gfc_current_locus
;
917 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
922 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
923 locus
*where ATTRIBUTE_UNUSED
)
925 attr
->ext_attr
|= 1 << ext_attr
;
930 /* Called from decl.c (attr_decl1) to check attributes, when declared
934 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
936 if (check_used (attr
, NULL
, where
))
939 return check_conflict (attr
, NULL
, where
);
944 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
947 if (check_used (attr
, NULL
, where
))
950 if (attr
->allocatable
)
952 duplicate_attr ("ALLOCATABLE", where
);
956 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
957 && !gfc_find_state (COMP_INTERFACE
))
959 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
964 attr
->allocatable
= 1;
965 return check_conflict (attr
, NULL
, where
);
970 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
972 if (check_used (attr
, name
, where
))
975 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
976 "Duplicate AUTOMATIC attribute specified at %L", where
))
980 return check_conflict (attr
, name
, where
);
985 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
988 if (check_used (attr
, name
, where
))
991 if (attr
->codimension
)
993 duplicate_attr ("CODIMENSION", where
);
997 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
998 && !gfc_find_state (COMP_INTERFACE
))
1000 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1001 "at %L", name
, where
);
1005 attr
->codimension
= 1;
1006 return check_conflict (attr
, name
, where
);
1011 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1014 if (check_used (attr
, name
, where
))
1017 if (attr
->dimension
)
1019 duplicate_attr ("DIMENSION", where
);
1023 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1024 && !gfc_find_state (COMP_INTERFACE
))
1026 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1027 "at %L", name
, where
);
1031 attr
->dimension
= 1;
1032 return check_conflict (attr
, name
, where
);
1037 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1040 if (check_used (attr
, name
, where
))
1043 attr
->contiguous
= 1;
1044 return check_conflict (attr
, name
, where
);
1049 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1052 if (check_used (attr
, NULL
, where
))
1057 duplicate_attr ("EXTERNAL", where
);
1061 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1064 attr
->proc_pointer
= 1;
1069 return check_conflict (attr
, NULL
, where
);
1074 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1077 if (check_used (attr
, NULL
, where
))
1080 if (attr
->intrinsic
)
1082 duplicate_attr ("INTRINSIC", where
);
1086 attr
->intrinsic
= 1;
1088 return check_conflict (attr
, NULL
, where
);
1093 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1096 if (check_used (attr
, NULL
, where
))
1101 duplicate_attr ("OPTIONAL", where
);
1106 return check_conflict (attr
, NULL
, where
);
1110 gfc_add_kind (symbol_attribute
*attr
, locus
*where
)
1114 duplicate_attr ("KIND", where
);
1119 return check_conflict (attr
, NULL
, where
);
1123 gfc_add_len (symbol_attribute
*attr
, locus
*where
)
1127 duplicate_attr ("LEN", where
);
1132 return check_conflict (attr
, NULL
, where
);
1137 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1140 if (check_used (attr
, NULL
, where
))
1143 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1144 && !gfc_find_state (COMP_INTERFACE
)))
1146 duplicate_attr ("POINTER", where
);
1150 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1151 || (attr
->if_source
== IFSRC_IFBODY
1152 && !gfc_find_state (COMP_INTERFACE
)))
1153 attr
->proc_pointer
= 1;
1157 return check_conflict (attr
, NULL
, where
);
1162 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1165 if (check_used (attr
, NULL
, where
))
1168 attr
->cray_pointer
= 1;
1169 return check_conflict (attr
, NULL
, where
);
1174 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1177 if (check_used (attr
, NULL
, where
))
1180 if (attr
->cray_pointee
)
1182 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1183 " statements", where
);
1187 attr
->cray_pointee
= 1;
1188 return check_conflict (attr
, NULL
, where
);
1193 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1195 if (check_used (attr
, name
, where
))
1198 if (attr
->is_protected
)
1200 if (!gfc_notify_std (GFC_STD_LEGACY
,
1201 "Duplicate PROTECTED attribute specified at %L",
1206 attr
->is_protected
= 1;
1207 return check_conflict (attr
, name
, where
);
1212 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1215 if (check_used (attr
, name
, where
))
1219 return check_conflict (attr
, name
, where
);
1224 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1228 if (check_used (attr
, name
, where
))
1231 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1234 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1239 if (s
== SAVE_EXPLICIT
)
1240 gfc_unset_implicit_pure (NULL
);
1242 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1244 if (!gfc_notify_std (GFC_STD_LEGACY
,
1245 "Duplicate SAVE attribute specified at %L",
1251 return check_conflict (attr
, name
, where
);
1256 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1259 if (check_used (attr
, name
, where
))
1264 if (!gfc_notify_std (GFC_STD_LEGACY
,
1265 "Duplicate VALUE attribute specified at %L",
1271 return check_conflict (attr
, name
, where
);
1276 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1278 /* No check_used needed as 11.2.1 of the F2003 standard allows
1279 that the local identifier made accessible by a use statement can be
1280 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1282 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1283 if (!gfc_notify_std (GFC_STD_LEGACY
,
1284 "Duplicate VOLATILE attribute specified at %L",
1288 attr
->volatile_
= 1;
1289 attr
->volatile_ns
= gfc_current_ns
;
1290 return check_conflict (attr
, name
, where
);
1295 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1297 /* No check_used needed as 11.2.1 of the F2003 standard allows
1298 that the local identifier made accessible by a use statement can be
1299 given a ASYNCHRONOUS attribute. */
1301 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1302 if (!gfc_notify_std (GFC_STD_LEGACY
,
1303 "Duplicate ASYNCHRONOUS attribute specified at %L",
1307 attr
->asynchronous
= 1;
1308 attr
->asynchronous_ns
= gfc_current_ns
;
1309 return check_conflict (attr
, name
, where
);
1314 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1317 if (check_used (attr
, name
, where
))
1320 if (attr
->threadprivate
)
1322 duplicate_attr ("THREADPRIVATE", where
);
1326 attr
->threadprivate
= 1;
1327 return check_conflict (attr
, name
, where
);
1332 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1336 if (check_used (attr
, name
, where
))
1339 if (attr
->omp_declare_target
)
1342 attr
->omp_declare_target
= 1;
1343 return check_conflict (attr
, name
, where
);
1348 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1352 if (check_used (attr
, name
, where
))
1355 if (attr
->omp_declare_target_link
)
1358 attr
->omp_declare_target_link
= 1;
1359 return check_conflict (attr
, name
, where
);
1364 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1367 if (check_used (attr
, name
, where
))
1370 if (attr
->oacc_declare_create
)
1373 attr
->oacc_declare_create
= 1;
1374 return check_conflict (attr
, name
, where
);
1379 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1382 if (check_used (attr
, name
, where
))
1385 if (attr
->oacc_declare_copyin
)
1388 attr
->oacc_declare_copyin
= 1;
1389 return check_conflict (attr
, name
, where
);
1394 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1397 if (check_used (attr
, name
, where
))
1400 if (attr
->oacc_declare_deviceptr
)
1403 attr
->oacc_declare_deviceptr
= 1;
1404 return check_conflict (attr
, name
, where
);
1409 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1412 if (check_used (attr
, name
, where
))
1415 if (attr
->oacc_declare_device_resident
)
1418 attr
->oacc_declare_device_resident
= 1;
1419 return check_conflict (attr
, name
, where
);
1424 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1427 if (check_used (attr
, NULL
, where
))
1432 duplicate_attr ("TARGET", where
);
1437 return check_conflict (attr
, NULL
, where
);
1442 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1445 if (check_used (attr
, name
, where
))
1448 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1450 return check_conflict (attr
, name
, where
);
1455 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1458 if (check_used (attr
, name
, where
))
1461 /* Duplicate attribute already checked for. */
1462 attr
->in_common
= 1;
1463 return check_conflict (attr
, name
, where
);
1468 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1471 /* Duplicate attribute already checked for. */
1472 attr
->in_equivalence
= 1;
1473 if (!check_conflict (attr
, name
, where
))
1476 if (attr
->flavor
== FL_VARIABLE
)
1479 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1484 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1487 if (check_used (attr
, name
, where
))
1491 return check_conflict (attr
, name
, where
);
1496 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1499 attr
->in_namelist
= 1;
1500 return check_conflict (attr
, name
, where
);
1505 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1508 if (check_used (attr
, name
, where
))
1512 return check_conflict (attr
, name
, where
);
1517 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1520 if (check_used (attr
, NULL
, where
))
1523 if (attr
->elemental
)
1525 duplicate_attr ("ELEMENTAL", where
);
1529 attr
->elemental
= 1;
1530 return check_conflict (attr
, NULL
, where
);
1535 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1538 if (check_used (attr
, NULL
, where
))
1543 duplicate_attr ("PURE", where
);
1548 return check_conflict (attr
, NULL
, where
);
1553 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1556 if (check_used (attr
, NULL
, where
))
1559 if (attr
->recursive
)
1561 duplicate_attr ("RECURSIVE", where
);
1565 attr
->recursive
= 1;
1566 return check_conflict (attr
, NULL
, where
);
1571 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1574 if (check_used (attr
, name
, where
))
1579 duplicate_attr ("ENTRY", where
);
1584 return check_conflict (attr
, name
, where
);
1589 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1592 if (attr
->flavor
!= FL_PROCEDURE
1593 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1597 return check_conflict (attr
, name
, where
);
1602 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1605 if (attr
->flavor
!= FL_PROCEDURE
1606 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1609 attr
->subroutine
= 1;
1610 return check_conflict (attr
, name
, where
);
1615 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1618 if (attr
->flavor
!= FL_PROCEDURE
1619 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1623 return check_conflict (attr
, name
, where
);
1628 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1631 if (check_used (attr
, NULL
, where
))
1634 if (attr
->flavor
!= FL_PROCEDURE
1635 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1638 if (attr
->procedure
)
1640 duplicate_attr ("PROCEDURE", where
);
1644 attr
->procedure
= 1;
1646 return check_conflict (attr
, NULL
, where
);
1651 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1655 duplicate_attr ("ABSTRACT", where
);
1661 return check_conflict (attr
, NULL
, where
);
1665 /* Flavors are special because some flavors are not what Fortran
1666 considers attributes and can be reaffirmed multiple times. */
1669 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1673 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1674 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1675 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1678 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1681 /* Copying a procedure dummy argument for a module procedure in a
1682 submodule results in the flavor being copied and would result in
1683 an error without this. */
1684 if (gfc_new_block
&& gfc_new_block
->abr_modproc_decl
1685 && attr
->flavor
== f
&& f
== FL_PROCEDURE
)
1688 if (attr
->flavor
!= FL_UNKNOWN
)
1691 where
= &gfc_current_locus
;
1694 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1695 gfc_code2string (flavors
, attr
->flavor
), name
,
1696 gfc_code2string (flavors
, f
), where
);
1698 gfc_error ("%s attribute conflicts with %s attribute at %L",
1699 gfc_code2string (flavors
, attr
->flavor
),
1700 gfc_code2string (flavors
, f
), where
);
1707 return check_conflict (attr
, name
, where
);
1712 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1713 const char *name
, locus
*where
)
1716 if (check_used (attr
, name
, where
))
1719 if (attr
->flavor
!= FL_PROCEDURE
1720 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1724 where
= &gfc_current_locus
;
1726 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
)
1728 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1729 && !gfc_notification_std (GFC_STD_F2008
))
1730 gfc_error ("%s procedure at %L is already declared as %s "
1731 "procedure. \nF2008: A pointer function assignment "
1732 "is ambiguous if it is the first executable statement "
1733 "after the specification block. Please add any other "
1734 "kind of executable statement before it. FIXME",
1735 gfc_code2string (procedures
, t
), where
,
1736 gfc_code2string (procedures
, attr
->proc
));
1738 gfc_error ("%s procedure at %L is already declared as %s "
1739 "procedure", gfc_code2string (procedures
, t
), where
,
1740 gfc_code2string (procedures
, attr
->proc
));
1747 /* Statement functions are always scalar and functions. */
1748 if (t
== PROC_ST_FUNCTION
1749 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1750 || attr
->dimension
))
1753 return check_conflict (attr
, name
, where
);
1758 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1761 if (check_used (attr
, NULL
, where
))
1764 if (attr
->intent
== INTENT_UNKNOWN
)
1766 attr
->intent
= intent
;
1767 return check_conflict (attr
, NULL
, where
);
1771 where
= &gfc_current_locus
;
1773 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1774 gfc_intent_string (attr
->intent
),
1775 gfc_intent_string (intent
), where
);
1781 /* No checks for use-association in public and private statements. */
1784 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1785 const char *name
, locus
*where
)
1788 if (attr
->access
== ACCESS_UNKNOWN
1789 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1791 attr
->access
= access
;
1792 return check_conflict (attr
, name
, where
);
1796 where
= &gfc_current_locus
;
1797 gfc_error ("ACCESS specification at %L was already specified", where
);
1803 /* Set the is_bind_c field for the given symbol_attribute. */
1806 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1807 int is_proc_lang_bind_spec
)
1810 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1811 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1812 "variables or common blocks", where
);
1813 else if (attr
->is_bind_c
)
1814 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1816 attr
->is_bind_c
= 1;
1819 where
= &gfc_current_locus
;
1821 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1824 return check_conflict (attr
, name
, where
);
1828 /* Set the extension field for the given symbol_attribute. */
1831 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1834 where
= &gfc_current_locus
;
1836 if (attr
->extension
)
1837 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1839 attr
->extension
= 1;
1841 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1849 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1850 gfc_formal_arglist
* formal
, locus
*where
)
1852 if (check_used (&sym
->attr
, sym
->name
, where
))
1855 /* Skip the following checks in the case of a module_procedures in a
1856 submodule since they will manifestly fail. */
1857 if (sym
->attr
.module_procedure
== 1
1858 && source
== IFSRC_DECL
)
1862 where
= &gfc_current_locus
;
1864 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1865 && sym
->attr
.if_source
!= IFSRC_DECL
)
1867 gfc_error ("Symbol %qs at %L already has an explicit interface",
1872 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1874 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1875 "body", sym
->name
, where
);
1880 sym
->formal
= formal
;
1881 sym
->attr
.if_source
= source
;
1887 /* Add a type to a symbol. */
1890 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1896 where
= &gfc_current_locus
;
1899 type
= sym
->result
->ts
.type
;
1901 type
= sym
->ts
.type
;
1903 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1904 type
= sym
->ns
->proc_name
->ts
.type
;
1906 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1907 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1908 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
1909 && !sym
->attr
.module_procedure
)
1911 if (sym
->attr
.use_assoc
)
1912 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
1913 "use-associated at %L", sym
->name
, where
, sym
->module
,
1916 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
1917 where
, gfc_basic_typename (type
));
1921 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1923 gfc_error ("Procedure %qs at %L may not have basic type of %s",
1924 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1928 flavor
= sym
->attr
.flavor
;
1930 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1931 || flavor
== FL_LABEL
1932 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1933 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1935 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
1944 /* Clears all attributes. */
1947 gfc_clear_attr (symbol_attribute
*attr
)
1949 memset (attr
, 0, sizeof (symbol_attribute
));
1953 /* Check for missing attributes in the new symbol. Currently does
1954 nothing, but it's not clear that it is unnecessary yet. */
1957 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1958 locus
*where ATTRIBUTE_UNUSED
)
1965 /* Copy an attribute to a symbol attribute, bit by bit. Some
1966 attributes have a lot of side-effects but cannot be present given
1967 where we are called from, so we ignore some bits. */
1970 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1972 int is_proc_lang_bind_spec
;
1974 /* In line with the other attributes, we only add bits but do not remove
1975 them; cf. also PR 41034. */
1976 dest
->ext_attr
|= src
->ext_attr
;
1978 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
1981 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
1983 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
1985 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
1987 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
1989 if (src
->optional
&& !gfc_add_optional (dest
, where
))
1991 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
1993 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
1995 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
1997 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
1999 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
2001 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
2003 if (src
->threadprivate
2004 && !gfc_add_threadprivate (dest
, NULL
, where
))
2006 if (src
->omp_declare_target
2007 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
2009 if (src
->omp_declare_target_link
2010 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
2012 if (src
->oacc_declare_create
2013 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
2015 if (src
->oacc_declare_copyin
2016 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
2018 if (src
->oacc_declare_deviceptr
2019 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
2021 if (src
->oacc_declare_device_resident
2022 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
2024 if (src
->target
&& !gfc_add_target (dest
, where
))
2026 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
2028 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
2033 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
2036 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2039 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2041 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2043 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2046 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2048 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2050 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2052 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2055 if (src
->flavor
!= FL_UNKNOWN
2056 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2059 if (src
->intent
!= INTENT_UNKNOWN
2060 && !gfc_add_intent (dest
, src
->intent
, where
))
2063 if (src
->access
!= ACCESS_UNKNOWN
2064 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2067 if (!gfc_missing_attr (dest
, where
))
2070 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2072 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2075 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2077 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2080 if (src
->is_c_interop
)
2081 dest
->is_c_interop
= 1;
2085 if (src
->external
&& !gfc_add_external (dest
, where
))
2087 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2089 if (src
->proc_pointer
)
2090 dest
->proc_pointer
= 1;
2099 /* A function to generate a dummy argument symbol using that from the
2100 interface declaration. Can be used for the result symbol as well if
2104 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2108 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2112 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2115 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2116 &gfc_current_locus
))
2119 if ((*dsym
)->attr
.dimension
)
2120 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2122 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2124 if ((*dsym
) != NULL
&& !result
2125 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2126 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2128 else if ((*dsym
) != NULL
&& result
2129 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2130 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2137 /************** Component name management ************/
2139 /* Component names of a derived type form their own little namespaces
2140 that are separate from all other spaces. The space is composed of
2141 a singly linked list of gfc_component structures whose head is
2142 located in the parent symbol. */
2145 /* Add a component name to a symbol. The call fails if the name is
2146 already present. On success, the component pointer is modified to
2147 point to the additional component structure. */
2150 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2151 gfc_component
**component
)
2153 gfc_component
*p
, *tail
;
2155 /* Check for existing components with the same name, but not for union
2156 components or containers. Unions and maps are anonymous so they have
2157 unique internal names which will never conflict.
2158 Don't use gfc_find_component here because it calls gfc_use_derived,
2159 but the derived type may not be fully defined yet. */
2162 for (p
= sym
->components
; p
; p
= p
->next
)
2164 if (strcmp (p
->name
, name
) == 0)
2166 gfc_error ("Component %qs at %C already declared at %L",
2174 if (sym
->attr
.extension
2175 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2176 name
, true, true, NULL
))
2178 gfc_error ("Component %qs at %C already in the parent type "
2179 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2183 /* Allocate a new component. */
2184 p
= gfc_get_component ();
2187 sym
->components
= p
;
2191 p
->name
= gfc_get_string ("%s", name
);
2192 p
->loc
= gfc_current_locus
;
2193 p
->ts
.type
= BT_UNKNOWN
;
2200 /* Recursive function to switch derived types of all symbol in a
2204 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2212 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2213 sym
->ts
.u
.derived
= to
;
2215 switch_types (st
->left
, from
, to
);
2216 switch_types (st
->right
, from
, to
);
2220 /* This subroutine is called when a derived type is used in order to
2221 make the final determination about which version to use. The
2222 standard requires that a type be defined before it is 'used', but
2223 such types can appear in IMPLICIT statements before the actual
2224 definition. 'Using' in this context means declaring a variable to
2225 be that type or using the type constructor.
2227 If a type is used and the components haven't been defined, then we
2228 have to have a derived type in a parent unit. We find the node in
2229 the other namespace and point the symtree node in this namespace to
2230 that node. Further reference to this name point to the correct
2231 node. If we can't find the node in a parent namespace, then we have
2234 This subroutine takes a pointer to a symbol node and returns a
2235 pointer to the translated node or NULL for an error. Usually there
2236 is no translation and we return the node we were passed. */
2239 gfc_use_derived (gfc_symbol
*sym
)
2249 if (sym
->attr
.unlimited_polymorphic
)
2252 if (sym
->attr
.generic
)
2253 sym
= gfc_find_dt_in_generic (sym
);
2255 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2256 return sym
; /* Already defined. */
2258 if (sym
->ns
->parent
== NULL
)
2261 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2263 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2267 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2270 /* Get rid of symbol sym, translating all references to s. */
2271 for (i
= 0; i
< GFC_LETTERS
; i
++)
2273 t
= &sym
->ns
->default_type
[i
];
2274 if (t
->u
.derived
== sym
)
2278 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2283 /* Unlink from list of modified symbols. */
2284 gfc_commit_symbol (sym
);
2286 switch_types (sym
->ns
->sym_root
, sym
, s
);
2288 /* TODO: Also have to replace sym -> s in other lists like
2289 namelists, common lists and interface lists. */
2290 gfc_free_symbol (sym
);
2295 gfc_error ("Derived type %qs at %C is being used before it is defined",
2301 /* Find the component with the given name in the union type symbol.
2302 If ref is not NULL it will be set to the chain of components through which
2303 the component can actually be accessed. This is necessary for unions because
2304 intermediate structures may be maps, nested structures, or other unions,
2305 all of which may (or must) be 'anonymous' to user code. */
2307 static gfc_component
*
2308 find_union_component (gfc_symbol
*un
, const char *name
,
2309 bool noaccess
, gfc_ref
**ref
)
2311 gfc_component
*m
, *check
;
2312 gfc_ref
*sref
, *tmp
;
2314 for (m
= un
->components
; m
; m
= m
->next
)
2316 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2320 /* Found component somewhere in m; chain the refs together. */
2324 sref
= gfc_get_ref ();
2325 sref
->type
= REF_COMPONENT
;
2326 sref
->u
.c
.component
= m
;
2327 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2332 /* Other checks (such as access) were done in the recursive calls. */
2339 /* Given a derived type node and a component name, try to locate the
2340 component structure. Returns the NULL pointer if the component is
2341 not found or the components are private. If noaccess is set, no access
2342 checks are done. If silent is set, an error will not be generated if
2343 the component cannot be found or accessed.
2345 If ref is not NULL, *ref is set to represent the chain of components
2346 required to get to the ultimate component.
2348 If the component is simply a direct subcomponent, or is inherited from a
2349 parent derived type in the given derived type, this is a single ref with its
2350 component set to the returned component.
2352 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2353 when the component is found through an implicit chain of nested union and
2354 map components. Unions and maps are "anonymous" substructures in FORTRAN
2355 which cannot be explicitly referenced, but the reference chain must be
2356 considered as in C for backend translation to correctly compute layouts.
2357 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2360 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2361 bool noaccess
, bool silent
, gfc_ref
**ref
)
2363 gfc_component
*p
, *check
;
2364 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2366 if (name
== NULL
|| sym
== NULL
)
2369 if (sym
->attr
.flavor
== FL_DERIVED
)
2370 sym
= gfc_use_derived (sym
);
2372 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2377 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2378 if (sym
->attr
.flavor
== FL_UNION
)
2379 return find_union_component (sym
, name
, noaccess
, ref
);
2381 if (ref
) *ref
= NULL
;
2382 for (p
= sym
->components
; p
; p
= p
->next
)
2384 /* Nest search into union's maps. */
2385 if (p
->ts
.type
== BT_UNION
)
2387 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2393 sref
= gfc_get_ref ();
2394 sref
->type
= REF_COMPONENT
;
2395 sref
->u
.c
.component
= p
;
2396 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2403 else if (strcmp (p
->name
, name
) == 0)
2409 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2411 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2412 if (p
->attr
.access
== ACCESS_PRIVATE
||
2413 (p
->attr
.access
!= ACCESS_PUBLIC
2414 && sym
->component_access
== ACCESS_PRIVATE
2415 && !is_parent_comp
))
2418 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2425 && sym
->attr
.extension
2426 && sym
->components
->ts
.type
== BT_DERIVED
)
2428 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2429 noaccess
, silent
, ref
);
2430 /* Do not overwrite the error. */
2435 if (p
== NULL
&& !silent
)
2436 gfc_error ("%qs at %C is not a member of the %qs structure",
2439 /* Component was found; build the ultimate component reference. */
2440 if (p
!= NULL
&& ref
)
2442 tmp
= gfc_get_ref ();
2443 tmp
->type
= REF_COMPONENT
;
2444 tmp
->u
.c
.component
= p
;
2446 /* Link the final component ref to the end of the chain of subrefs. */
2450 for (; sref
->next
; sref
= sref
->next
)
2462 /* Given a symbol, free all of the component structures and everything
2466 free_components (gfc_component
*p
)
2474 gfc_free_array_spec (p
->as
);
2475 gfc_free_expr (p
->initializer
);
2477 gfc_free_expr (p
->kind_expr
);
2479 gfc_free_actual_arglist (p
->param_list
);
2487 /******************** Statement label management ********************/
2489 /* Comparison function for statement labels, used for managing the
2493 compare_st_labels (void *a1
, void *b1
)
2495 int a
= ((gfc_st_label
*) a1
)->value
;
2496 int b
= ((gfc_st_label
*) b1
)->value
;
2502 /* Free a single gfc_st_label structure, making sure the tree is not
2503 messed up. This function is called only when some parse error
2507 gfc_free_st_label (gfc_st_label
*label
)
2513 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2515 if (label
->format
!= NULL
)
2516 gfc_free_expr (label
->format
);
2522 /* Free a whole tree of gfc_st_label structures. */
2525 free_st_labels (gfc_st_label
*label
)
2531 free_st_labels (label
->left
);
2532 free_st_labels (label
->right
);
2534 if (label
->format
!= NULL
)
2535 gfc_free_expr (label
->format
);
2540 /* Given a label number, search for and return a pointer to the label
2541 structure, creating it if it does not exist. */
2544 gfc_get_st_label (int labelno
)
2549 if (gfc_current_state () == COMP_DERIVED
)
2550 ns
= gfc_current_block ()->f2k_derived
;
2553 /* Find the namespace of the scoping unit:
2554 If we're in a BLOCK construct, jump to the parent namespace. */
2555 ns
= gfc_current_ns
;
2556 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2560 /* First see if the label is already in this namespace. */
2564 if (lp
->value
== labelno
)
2567 if (lp
->value
< labelno
)
2573 lp
= XCNEW (gfc_st_label
);
2575 lp
->value
= labelno
;
2576 lp
->defined
= ST_LABEL_UNKNOWN
;
2577 lp
->referenced
= ST_LABEL_UNKNOWN
;
2580 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2586 /* Called when a statement with a statement label is about to be
2587 accepted. We add the label to the list of the current namespace,
2588 making sure it hasn't been defined previously and referenced
2592 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2596 labelno
= lp
->value
;
2598 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2599 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2600 &lp
->where
, label_locus
);
2603 lp
->where
= *label_locus
;
2607 case ST_LABEL_FORMAT
:
2608 if (lp
->referenced
== ST_LABEL_TARGET
2609 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2610 gfc_error ("Label %d at %C already referenced as branch target",
2613 lp
->defined
= ST_LABEL_FORMAT
;
2617 case ST_LABEL_TARGET
:
2618 case ST_LABEL_DO_TARGET
:
2619 if (lp
->referenced
== ST_LABEL_FORMAT
)
2620 gfc_error ("Label %d at %C already referenced as a format label",
2625 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2626 && !gfc_notify_std (GFC_STD_F95_OBS
, "DO termination statement "
2627 "which is not END DO or CONTINUE with "
2628 "label %d at %C", labelno
))
2633 lp
->defined
= ST_LABEL_BAD_TARGET
;
2634 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2640 /* Reference a label. Given a label and its type, see if that
2641 reference is consistent with what is known about that label,
2642 updating the unknown state. Returns false if something goes
2646 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2648 gfc_sl_type label_type
;
2655 labelno
= lp
->value
;
2657 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2658 label_type
= lp
->defined
;
2661 label_type
= lp
->referenced
;
2662 lp
->where
= gfc_current_locus
;
2665 if (label_type
== ST_LABEL_FORMAT
2666 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2668 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2673 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2674 || label_type
== ST_LABEL_BAD_TARGET
)
2675 && type
== ST_LABEL_FORMAT
)
2677 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2682 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2683 && !gfc_notify_std (GFC_STD_F95_OBS
, "Shared DO termination label %d "
2687 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2688 lp
->referenced
= type
;
2696 /************** Symbol table management subroutines ****************/
2698 /* Basic details: Fortran 95 requires a potentially unlimited number
2699 of distinct namespaces when compiling a program unit. This case
2700 occurs during a compilation of internal subprograms because all of
2701 the internal subprograms must be read before we can start
2702 generating code for the host.
2704 Given the tricky nature of the Fortran grammar, we must be able to
2705 undo changes made to a symbol table if the current interpretation
2706 of a statement is found to be incorrect. Whenever a symbol is
2707 looked up, we make a copy of it and link to it. All of these
2708 symbols are kept in a vector so that we can commit or
2709 undo the changes at a later time.
2711 A symtree may point to a symbol node outside of its namespace. In
2712 this case, that symbol has been used as a host associated variable
2713 at some previous time. */
2715 /* Allocate a new namespace structure. Copies the implicit types from
2716 PARENT if PARENT_TYPES is set. */
2719 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2726 ns
= XCNEW (gfc_namespace
);
2727 ns
->sym_root
= NULL
;
2728 ns
->uop_root
= NULL
;
2729 ns
->tb_sym_root
= NULL
;
2730 ns
->finalizers
= NULL
;
2731 ns
->default_access
= ACCESS_UNKNOWN
;
2732 ns
->parent
= parent
;
2734 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2736 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2737 ns
->tb_op
[in
] = NULL
;
2740 /* Initialize default implicit types. */
2741 for (i
= 'a'; i
<= 'z'; i
++)
2743 ns
->set_flag
[i
- 'a'] = 0;
2744 ts
= &ns
->default_type
[i
- 'a'];
2746 if (parent_types
&& ns
->parent
!= NULL
)
2748 /* Copy parent settings. */
2749 *ts
= ns
->parent
->default_type
[i
- 'a'];
2753 if (flag_implicit_none
!= 0)
2759 if ('i' <= i
&& i
<= 'n')
2761 ts
->type
= BT_INTEGER
;
2762 ts
->kind
= gfc_default_integer_kind
;
2767 ts
->kind
= gfc_default_real_kind
;
2771 if (parent_types
&& ns
->parent
!= NULL
)
2772 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2780 /* Comparison function for symtree nodes. */
2783 compare_symtree (void *_st1
, void *_st2
)
2785 gfc_symtree
*st1
, *st2
;
2787 st1
= (gfc_symtree
*) _st1
;
2788 st2
= (gfc_symtree
*) _st2
;
2790 return strcmp (st1
->name
, st2
->name
);
2794 /* Allocate a new symtree node and associate it with the new symbol. */
2797 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2801 st
= XCNEW (gfc_symtree
);
2802 st
->name
= gfc_get_string ("%s", name
);
2804 gfc_insert_bbt (root
, st
, compare_symtree
);
2809 /* Delete a symbol from the tree. Does not free the symbol itself! */
2812 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2814 gfc_symtree st
, *st0
;
2817 /* Submodules are marked as mod.submod. When freeing a submodule
2818 symbol, the symtree only has "submod", so adjust that here. */
2820 p
= strrchr(name
, '.');
2826 st0
= gfc_find_symtree (*root
, p
);
2828 st
.name
= gfc_get_string ("%s", p
);
2829 gfc_delete_bbt (root
, &st
, compare_symtree
);
2835 /* Given a root symtree node and a name, try to find the symbol within
2836 the namespace. Returns NULL if the symbol is not found. */
2839 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2845 c
= strcmp (name
, st
->name
);
2849 st
= (c
< 0) ? st
->left
: st
->right
;
2856 /* Return a symtree node with a name that is guaranteed to be unique
2857 within the namespace and corresponds to an illegal fortran name. */
2860 gfc_get_unique_symtree (gfc_namespace
*ns
)
2862 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2863 static int serial
= 0;
2865 sprintf (name
, "@%d", serial
++);
2866 return gfc_new_symtree (&ns
->sym_root
, name
);
2870 /* Given a name find a user operator node, creating it if it doesn't
2871 exist. These are much simpler than symbols because they can't be
2872 ambiguous with one another. */
2875 gfc_get_uop (const char *name
)
2879 gfc_namespace
*ns
= gfc_current_ns
;
2883 st
= gfc_find_symtree (ns
->uop_root
, name
);
2887 st
= gfc_new_symtree (&ns
->uop_root
, name
);
2889 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2890 uop
->name
= gfc_get_string ("%s", name
);
2891 uop
->access
= ACCESS_UNKNOWN
;
2898 /* Given a name find the user operator node. Returns NULL if it does
2902 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2907 ns
= gfc_current_ns
;
2909 st
= gfc_find_symtree (ns
->uop_root
, name
);
2910 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2914 /* Update a symbol's common_block field, and take care of the associated
2915 memory management. */
2918 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
2920 if (sym
->common_block
== common_block
)
2923 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
2925 sym
->common_block
->refs
--;
2926 if (sym
->common_block
->refs
== 0)
2927 free (sym
->common_block
);
2929 sym
->common_block
= common_block
;
2933 /* Remove a gfc_symbol structure and everything it points to. */
2936 gfc_free_symbol (gfc_symbol
*sym
)
2942 gfc_free_array_spec (sym
->as
);
2944 free_components (sym
->components
);
2946 gfc_free_expr (sym
->value
);
2948 gfc_free_namelist (sym
->namelist
);
2950 if (sym
->ns
!= sym
->formal_ns
)
2951 gfc_free_namespace (sym
->formal_ns
);
2953 if (!sym
->attr
.generic_copy
)
2954 gfc_free_interface (sym
->generic
);
2956 gfc_free_formal_arglist (sym
->formal
);
2958 gfc_free_namespace (sym
->f2k_derived
);
2960 set_symbol_common_block (sym
, NULL
);
2962 if (sym
->param_list
)
2963 gfc_free_actual_arglist (sym
->param_list
);
2969 /* Decrease the reference counter and free memory when we reach zero. */
2972 gfc_release_symbol (gfc_symbol
*sym
)
2977 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
2978 && (!sym
->attr
.entry
|| !sym
->module
))
2980 /* As formal_ns contains a reference to sym, delete formal_ns just
2981 before the deletion of sym. */
2982 gfc_namespace
*ns
= sym
->formal_ns
;
2983 sym
->formal_ns
= NULL
;
2984 gfc_free_namespace (ns
);
2991 gcc_assert (sym
->refs
== 0);
2992 gfc_free_symbol (sym
);
2996 /* Allocate and initialize a new symbol node. */
2999 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
3003 p
= XCNEW (gfc_symbol
);
3005 gfc_clear_ts (&p
->ts
);
3006 gfc_clear_attr (&p
->attr
);
3009 p
->declared_at
= gfc_current_locus
;
3011 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
3012 gfc_internal_error ("new_symbol(): Symbol name too long");
3014 p
->name
= gfc_get_string ("%s", name
);
3016 /* Make sure flags for symbol being C bound are clear initially. */
3017 p
->attr
.is_bind_c
= 0;
3018 p
->attr
.is_iso_c
= 0;
3020 /* Clear the ptrs we may need. */
3021 p
->common_block
= NULL
;
3022 p
->f2k_derived
= NULL
;
3024 p
->fn_result_spec
= 0;
3030 /* Generate an error if a symbol is ambiguous. */
3033 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
3036 if (st
->n
.sym
->module
)
3037 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3038 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
3040 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3041 "from current program unit", name
, st
->n
.sym
->name
);
3045 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3046 selector on the stack. If yes, replace it by the corresponding temporary. */
3049 select_type_insert_tmp (gfc_symtree
**st
)
3051 gfc_select_type_stack
*stack
= select_type_stack
;
3052 for (; stack
; stack
= stack
->prev
)
3053 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3056 select_type_insert_tmp (st
);
3062 /* Look for a symtree in the current procedure -- that is, go up to
3063 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3066 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3070 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3074 if (!ns
->construct_entities
)
3083 /* Search for a symtree starting in the current namespace, resorting to
3084 any parent namespaces if requested by a nonzero parent_flag.
3085 Returns nonzero if the name is ambiguous. */
3088 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3089 gfc_symtree
**result
)
3094 ns
= gfc_current_ns
;
3098 st
= gfc_find_symtree (ns
->sym_root
, name
);
3101 select_type_insert_tmp (&st
);
3104 /* Ambiguous generic interfaces are permitted, as long
3105 as the specific interfaces are different. */
3106 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3108 ambiguous_symbol (name
, st
);
3118 /* Don't escape an interface block. */
3119 if (ns
&& !ns
->has_import_set
3120 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3127 if (gfc_current_state() == COMP_DERIVED
3128 && gfc_current_block ()->attr
.pdt_template
)
3130 gfc_symbol
*der
= gfc_current_block ();
3131 for (; der
; der
= gfc_get_derived_super_type (der
))
3133 if (der
->f2k_derived
&& der
->f2k_derived
->sym_root
)
3135 st
= gfc_find_symtree (der
->f2k_derived
->sym_root
, name
);
3150 /* Same, but returns the symbol instead. */
3153 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3154 gfc_symbol
**result
)
3159 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3164 *result
= st
->n
.sym
;
3170 /* Tells whether there is only one set of changes in the stack. */
3173 single_undo_checkpoint_p (void)
3175 if (latest_undo_chgset
== &default_undo_chgset_var
)
3177 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3182 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3187 /* Save symbol with the information necessary to back it out. */
3190 gfc_save_symbol_data (gfc_symbol
*sym
)
3195 if (!single_undo_checkpoint_p ())
3197 /* If there is more than one change set, look for the symbol in the
3198 current one. If it is found there, we can reuse it. */
3199 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3202 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3206 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3209 s
= XCNEW (gfc_symbol
);
3211 sym
->old_symbol
= s
;
3214 latest_undo_chgset
->syms
.safe_push (sym
);
3218 /* Given a name, find a symbol, or create it if it does not exist yet
3219 in the current namespace. If the symbol is found we make sure that
3222 The integer return code indicates
3224 1 The symbol name was ambiguous
3225 2 The name meant to be established was already host associated.
3227 So if the return value is nonzero, then an error was issued. */
3230 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3231 bool allow_subroutine
)
3236 /* This doesn't usually happen during resolution. */
3238 ns
= gfc_current_ns
;
3240 /* Try to find the symbol in ns. */
3241 st
= gfc_find_symtree (ns
->sym_root
, name
);
3243 if (st
== NULL
&& ns
->omp_udr_ns
)
3246 st
= gfc_find_symtree (ns
->sym_root
, name
);
3251 /* If not there, create a new symbol. */
3252 p
= gfc_new_symbol (name
, ns
);
3254 /* Add to the list of tentative symbols. */
3255 p
->old_symbol
= NULL
;
3258 latest_undo_chgset
->syms
.safe_push (p
);
3260 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3267 /* Make sure the existing symbol is OK. Ambiguous
3268 generic interfaces are permitted, as long as the
3269 specific interfaces are different. */
3270 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3272 ambiguous_symbol (name
, st
);
3277 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3278 && !(allow_subroutine
&& p
->attr
.subroutine
)
3279 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3280 && (ns
->has_import_set
|| p
->attr
.imported
)))
3282 /* Symbol is from another namespace. */
3283 gfc_error ("Symbol %qs at %C has already been host associated",
3290 /* Copy in case this symbol is changed. */
3291 gfc_save_symbol_data (p
);
3300 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3305 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3310 *result
= st
->n
.sym
;
3317 /* Subroutine that searches for a symbol, creating it if it doesn't
3318 exist, but tries to host-associate the symbol if possible. */
3321 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3326 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3330 gfc_save_symbol_data (st
->n
.sym
);
3335 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3345 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3350 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3355 i
= gfc_get_ha_sym_tree (name
, &st
);
3358 *result
= st
->n
.sym
;
3366 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3367 head->name as the common_root symtree's name might be mangled. */
3369 static gfc_symtree
*
3370 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3373 gfc_symtree
*result
;
3378 if (st
->n
.common
== head
)
3381 result
= find_common_symtree (st
->left
, head
);
3383 result
= find_common_symtree (st
->right
, head
);
3389 /* Clear the given storage, and make it the current change set for registering
3390 changed symbols. Its contents are freed after a call to
3391 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
3392 it is up to the caller to free the storage itself. It is usually a local
3393 variable, so there is nothing to do anyway. */
3396 gfc_new_undo_checkpoint (gfc_undo_change_set
&chg_syms
)
3398 chg_syms
.syms
= vNULL
;
3399 chg_syms
.tbps
= vNULL
;
3400 chg_syms
.previous
= latest_undo_chgset
;
3401 latest_undo_chgset
= &chg_syms
;
3405 /* Restore previous state of symbol. Just copy simple stuff. */
3408 restore_old_symbol (gfc_symbol
*p
)
3413 old
= p
->old_symbol
;
3415 p
->ts
.type
= old
->ts
.type
;
3416 p
->ts
.kind
= old
->ts
.kind
;
3418 p
->attr
= old
->attr
;
3420 if (p
->value
!= old
->value
)
3422 gcc_checking_assert (old
->value
== NULL
);
3423 gfc_free_expr (p
->value
);
3427 if (p
->as
!= old
->as
)
3430 gfc_free_array_spec (p
->as
);
3434 p
->generic
= old
->generic
;
3435 p
->component_access
= old
->component_access
;
3437 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3439 gfc_free_namelist (p
->namelist
);
3444 if (p
->namelist_tail
!= old
->namelist_tail
)
3446 gfc_free_namelist (old
->namelist_tail
->next
);
3447 old
->namelist_tail
->next
= NULL
;
3451 p
->namelist_tail
= old
->namelist_tail
;
3453 if (p
->formal
!= old
->formal
)
3455 gfc_free_formal_arglist (p
->formal
);
3456 p
->formal
= old
->formal
;
3459 set_symbol_common_block (p
, old
->common_block
);
3460 p
->common_head
= old
->common_head
;
3462 p
->old_symbol
= old
->old_symbol
;
3467 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3468 the structure itself. */
3471 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3478 /* Given a change set pointer, free its target's contents and update it with
3479 the address of the previous change set. Note that only the contents are
3480 freed, not the target itself (the contents' container). It is not a problem
3481 as the latter will be a local variable usually. */
3484 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3486 free_undo_change_set_data (*cs
);
3491 static void free_old_symbol (gfc_symbol
*sym
);
3494 /* Merges the current change set into the previous one. The changes themselves
3495 are left untouched; only one checkpoint is forgotten. */
3498 gfc_drop_last_undo_checkpoint (void)
3503 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3505 /* No need to loop in this case. */
3506 if (s
->old_symbol
== NULL
)
3509 /* Remove the duplicate symbols. */
3510 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3513 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3515 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3516 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3517 shall contain from now on the backup symbol for S as it was
3518 at the checkpoint before. */
3519 if (s
->old_symbol
->gfc_new
)
3521 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3522 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3523 free_old_symbol (s
);
3526 restore_old_symbol (s
->old_symbol
);
3531 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3532 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3534 pop_undo_change_set (latest_undo_chgset
);
3538 /* Undoes all the changes made to symbols since the previous checkpoint.
3539 This subroutine is made simpler due to the fact that attributes are
3540 never removed once added. */
3543 gfc_restore_last_undo_checkpoint (void)
3548 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3550 /* Symbol in a common block was new. Or was old and just put in common */
3552 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3554 /* If the symbol was added to any common block, it
3555 needs to be removed to stop the resolver looking
3556 for a (possibly) dead symbol. */
3557 if (p
->common_block
->head
== p
&& !p
->common_next
)
3559 gfc_symtree st
, *st0
;
3560 st0
= find_common_symtree (p
->ns
->common_root
,
3564 st
.name
= st0
->name
;
3565 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3570 if (p
->common_block
->head
== p
)
3571 p
->common_block
->head
= p
->common_next
;
3574 gfc_symbol
*cparent
, *csym
;
3576 cparent
= p
->common_block
->head
;
3577 csym
= cparent
->common_next
;
3582 csym
= csym
->common_next
;
3585 gcc_assert(cparent
->common_next
== p
);
3586 cparent
->common_next
= csym
->common_next
;
3588 p
->common_next
= NULL
;
3592 /* The derived type is saved in the symtree with the first
3593 letter capitalized; the all lower-case version to the
3594 derived type contains its associated generic function. */
3595 if (gfc_fl_struct (p
->attr
.flavor
))
3596 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3598 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3600 gfc_release_symbol (p
);
3603 restore_old_symbol (p
);
3606 latest_undo_chgset
->syms
.truncate (0);
3607 latest_undo_chgset
->tbps
.truncate (0);
3609 if (!single_undo_checkpoint_p ())
3610 pop_undo_change_set (latest_undo_chgset
);
3614 /* Makes sure that there is only one set of changes; in other words we haven't
3615 forgotten to pair a call to gfc_new_checkpoint with a call to either
3616 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3619 enforce_single_undo_checkpoint (void)
3621 gcc_checking_assert (single_undo_checkpoint_p ());
3625 /* Undoes all the changes made to symbols in the current statement. */
3628 gfc_undo_symbols (void)
3630 enforce_single_undo_checkpoint ();
3631 gfc_restore_last_undo_checkpoint ();
3635 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3636 components of old_symbol that might need deallocation are the "allocatables"
3637 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3638 namelist_tail. In case these differ between old_symbol and sym, it's just
3639 because sym->namelist has gotten a few more items. */
3642 free_old_symbol (gfc_symbol
*sym
)
3645 if (sym
->old_symbol
== NULL
)
3648 if (sym
->old_symbol
->as
!= sym
->as
)
3649 gfc_free_array_spec (sym
->old_symbol
->as
);
3651 if (sym
->old_symbol
->value
!= sym
->value
)
3652 gfc_free_expr (sym
->old_symbol
->value
);
3654 if (sym
->old_symbol
->formal
!= sym
->formal
)
3655 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3657 free (sym
->old_symbol
);
3658 sym
->old_symbol
= NULL
;
3662 /* Makes the changes made in the current statement permanent-- gets
3663 rid of undo information. */
3666 gfc_commit_symbols (void)
3669 gfc_typebound_proc
*tbp
;
3672 enforce_single_undo_checkpoint ();
3674 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3678 free_old_symbol (p
);
3680 latest_undo_chgset
->syms
.truncate (0);
3682 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3684 latest_undo_chgset
->tbps
.truncate (0);
3688 /* Makes the changes made in one symbol permanent -- gets rid of undo
3692 gfc_commit_symbol (gfc_symbol
*sym
)
3697 enforce_single_undo_checkpoint ();
3699 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3702 latest_undo_chgset
->syms
.unordered_remove (i
);
3709 free_old_symbol (sym
);
3713 /* Recursively free trees containing type-bound procedures. */
3716 free_tb_tree (gfc_symtree
*t
)
3721 free_tb_tree (t
->left
);
3722 free_tb_tree (t
->right
);
3724 /* TODO: Free type-bound procedure structs themselves; probably needs some
3725 sort of ref-counting mechanism. */
3731 /* Recursive function that deletes an entire tree and all the common
3732 head structures it points to. */
3735 free_common_tree (gfc_symtree
* common_tree
)
3737 if (common_tree
== NULL
)
3740 free_common_tree (common_tree
->left
);
3741 free_common_tree (common_tree
->right
);
3747 /* Recursive function that deletes an entire tree and all the common
3748 head structures it points to. */
3751 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3753 if (omp_udr_tree
== NULL
)
3756 free_omp_udr_tree (omp_udr_tree
->left
);
3757 free_omp_udr_tree (omp_udr_tree
->right
);
3759 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3760 free (omp_udr_tree
);
3764 /* Recursive function that deletes an entire tree and all the user
3765 operator nodes that it contains. */
3768 free_uop_tree (gfc_symtree
*uop_tree
)
3770 if (uop_tree
== NULL
)
3773 free_uop_tree (uop_tree
->left
);
3774 free_uop_tree (uop_tree
->right
);
3776 gfc_free_interface (uop_tree
->n
.uop
->op
);
3777 free (uop_tree
->n
.uop
);
3782 /* Recursive function that deletes an entire tree and all the symbols
3783 that it contains. */
3786 free_sym_tree (gfc_symtree
*sym_tree
)
3788 if (sym_tree
== NULL
)
3791 free_sym_tree (sym_tree
->left
);
3792 free_sym_tree (sym_tree
->right
);
3794 gfc_release_symbol (sym_tree
->n
.sym
);
3799 /* Free the derived type list. */
3802 gfc_free_dt_list (void)
3804 gfc_dt_list
*dt
, *n
;
3806 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3812 gfc_derived_types
= NULL
;
3816 /* Free the gfc_equiv_info's. */
3819 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3823 gfc_free_equiv_infos (s
->next
);
3828 /* Free the gfc_equiv_lists. */
3831 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3835 gfc_free_equiv_lists (l
->next
);
3836 gfc_free_equiv_infos (l
->equiv
);
3841 /* Free a finalizer procedure list. */
3844 gfc_free_finalizer (gfc_finalizer
* el
)
3848 gfc_release_symbol (el
->proc_sym
);
3854 gfc_free_finalizer_list (gfc_finalizer
* list
)
3858 gfc_finalizer
* current
= list
;
3860 gfc_free_finalizer (current
);
3865 /* Create a new gfc_charlen structure and add it to a namespace.
3866 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3869 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3873 cl
= gfc_get_charlen ();
3878 cl
->length
= gfc_copy_expr (old_cl
->length
);
3879 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3880 cl
->backend_decl
= old_cl
->backend_decl
;
3881 cl
->passed_length
= old_cl
->passed_length
;
3882 cl
->resolved
= old_cl
->resolved
;
3885 /* Put into namespace. */
3886 cl
->next
= ns
->cl_list
;
3893 /* Free the charlen list from cl to end (end is not freed).
3894 Free the whole list if end is NULL. */
3897 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3901 for (; cl
!= end
; cl
= cl2
)
3906 gfc_free_expr (cl
->length
);
3912 /* Free entry list structs. */
3915 free_entry_list (gfc_entry_list
*el
)
3917 gfc_entry_list
*next
;
3924 free_entry_list (next
);
3928 /* Free a namespace structure and everything below it. Interface
3929 lists associated with intrinsic operators are not freed. These are
3930 taken care of when a specific name is freed. */
3933 gfc_free_namespace (gfc_namespace
*ns
)
3935 gfc_namespace
*p
, *q
;
3945 gcc_assert (ns
->refs
== 0);
3947 gfc_free_statements (ns
->code
);
3949 free_sym_tree (ns
->sym_root
);
3950 free_uop_tree (ns
->uop_root
);
3951 free_common_tree (ns
->common_root
);
3952 free_omp_udr_tree (ns
->omp_udr_root
);
3953 free_tb_tree (ns
->tb_sym_root
);
3954 free_tb_tree (ns
->tb_uop_root
);
3955 gfc_free_finalizer_list (ns
->finalizers
);
3956 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
3957 gfc_free_charlen (ns
->cl_list
, NULL
);
3958 free_st_labels (ns
->st_labels
);
3960 free_entry_list (ns
->entries
);
3961 gfc_free_equiv (ns
->equiv
);
3962 gfc_free_equiv_lists (ns
->equiv_lists
);
3963 gfc_free_use_stmts (ns
->use_stmts
);
3965 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3966 gfc_free_interface (ns
->op
[i
]);
3968 gfc_free_data (ns
->data
);
3972 /* Recursively free any contained namespaces. */
3977 gfc_free_namespace (q
);
3983 gfc_symbol_init_2 (void)
3986 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3991 gfc_symbol_done_2 (void)
3993 gfc_free_namespace (gfc_current_ns
);
3994 gfc_current_ns
= NULL
;
3995 gfc_free_dt_list ();
3997 enforce_single_undo_checkpoint ();
3998 free_undo_change_set_data (*latest_undo_chgset
);
4002 /* Count how many nodes a symtree has. */
4005 count_st_nodes (const gfc_symtree
*st
)
4011 nodes
= count_st_nodes (st
->left
);
4013 nodes
+= count_st_nodes (st
->right
);
4019 /* Convert symtree tree into symtree vector. */
4022 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
4027 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
4028 st_vec
[node_cntr
++] = st
;
4029 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
4035 /* Traverse namespace. As the functions might modify the symtree, we store the
4036 symtree as a vector and operate on this vector. Note: We assume that
4037 sym_func or st_func never deletes nodes from the symtree - only adding is
4038 allowed. Additionally, newly added nodes are not traversed. */
4041 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
4042 void (*sym_func
) (gfc_symbol
*))
4044 gfc_symtree
**st_vec
;
4045 unsigned nodes
, i
, node_cntr
;
4047 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
4048 nodes
= count_st_nodes (st
);
4049 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
4051 fill_st_vector (st
, st_vec
, node_cntr
);
4056 for (i
= 0; i
< nodes
; i
++)
4057 st_vec
[i
]->n
.sym
->mark
= 0;
4058 for (i
= 0; i
< nodes
; i
++)
4059 if (!st_vec
[i
]->n
.sym
->mark
)
4061 (*sym_func
) (st_vec
[i
]->n
.sym
);
4062 st_vec
[i
]->n
.sym
->mark
= 1;
4066 for (i
= 0; i
< nodes
; i
++)
4067 (*st_func
) (st_vec
[i
]);
4071 /* Recursively traverse the symtree nodes. */
4074 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4076 do_traverse_symtree (st
, st_func
, NULL
);
4080 /* Call a given function for all symbols in the namespace. We take
4081 care that each gfc_symbol node is called exactly once. */
4084 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4086 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4090 /* Return TRUE when name is the name of an intrinsic type. */
4093 gfc_is_intrinsic_typename (const char *name
)
4095 if (strcmp (name
, "integer") == 0
4096 || strcmp (name
, "real") == 0
4097 || strcmp (name
, "character") == 0
4098 || strcmp (name
, "logical") == 0
4099 || strcmp (name
, "complex") == 0
4100 || strcmp (name
, "doubleprecision") == 0
4101 || strcmp (name
, "doublecomplex") == 0)
4108 /* Return TRUE if the symbol is an automatic variable. */
4111 gfc_is_var_automatic (gfc_symbol
*sym
)
4113 /* Pointer and allocatable variables are never automatic. */
4114 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4116 /* Check for arrays with non-constant size. */
4117 if (sym
->attr
.dimension
&& sym
->as
4118 && !gfc_is_compile_time_shape (sym
->as
))
4120 /* Check for non-constant length character variables. */
4121 if (sym
->ts
.type
== BT_CHARACTER
4123 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4125 /* Variables with explicit AUTOMATIC attribute. */
4126 if (sym
->attr
.automatic
)
4132 /* Given a symbol, mark it as SAVEd if it is allowed. */
4135 save_symbol (gfc_symbol
*sym
)
4138 if (sym
->attr
.use_assoc
)
4141 if (sym
->attr
.in_common
4144 || sym
->attr
.flavor
!= FL_VARIABLE
)
4146 /* Automatic objects are not saved. */
4147 if (gfc_is_var_automatic (sym
))
4149 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4153 /* Mark those symbols which can be SAVEd as such. */
4156 gfc_save_all (gfc_namespace
*ns
)
4158 gfc_traverse_ns (ns
, save_symbol
);
4162 /* Make sure that no changes to symbols are pending. */
4165 gfc_enforce_clean_symbol_state(void)
4167 enforce_single_undo_checkpoint ();
4168 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4172 /************** Global symbol handling ************/
4175 /* Search a tree for the global symbol. */
4178 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4187 c
= strcmp (name
, symbol
->name
);
4191 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4198 /* Compare two global symbols. Used for managing the BB tree. */
4201 gsym_compare (void *_s1
, void *_s2
)
4203 gfc_gsymbol
*s1
, *s2
;
4205 s1
= (gfc_gsymbol
*) _s1
;
4206 s2
= (gfc_gsymbol
*) _s2
;
4207 return strcmp (s1
->name
, s2
->name
);
4211 /* Get a global symbol, creating it if it doesn't exist. */
4214 gfc_get_gsymbol (const char *name
)
4218 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4222 s
= XCNEW (gfc_gsymbol
);
4223 s
->type
= GSYM_UNKNOWN
;
4224 s
->name
= gfc_get_string ("%s", name
);
4226 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4233 get_iso_c_binding_dt (int sym_id
)
4235 gfc_dt_list
*dt_list
;
4237 dt_list
= gfc_derived_types
;
4239 /* Loop through the derived types in the name list, searching for
4240 the desired symbol from iso_c_binding. Search the parent namespaces
4241 if necessary and requested to (parent_flag). */
4242 while (dt_list
!= NULL
)
4244 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
4245 && dt_list
->derived
->intmod_sym_id
== sym_id
)
4246 return dt_list
->derived
;
4248 dt_list
= dt_list
->next
;
4255 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4256 with C. This is necessary for any derived type that is BIND(C) and for
4257 derived types that are parameters to functions that are BIND(C). All
4258 fields of the derived type are required to be interoperable, and are tested
4259 for such. If an error occurs, the errors are reported here, allowing for
4260 multiple errors to be handled for a single derived type. */
4263 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4265 gfc_component
*curr_comp
= NULL
;
4266 bool is_c_interop
= false;
4269 if (derived_sym
== NULL
)
4270 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4271 "unexpectedly NULL");
4273 /* If we've already looked at this derived symbol, do not look at it again
4274 so we don't repeat warnings/errors. */
4275 if (derived_sym
->ts
.is_c_interop
)
4278 /* The derived type must have the BIND attribute to be interoperable
4279 J3/04-007, Section 15.2.3. */
4280 if (derived_sym
->attr
.is_bind_c
!= 1)
4282 derived_sym
->ts
.is_c_interop
= 0;
4283 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4284 "attribute to be C interoperable", derived_sym
->name
,
4285 &(derived_sym
->declared_at
));
4289 curr_comp
= derived_sym
->components
;
4291 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4292 empty struct. Section 15.2 in Fortran 2003 states: "The following
4293 subclauses define the conditions under which a Fortran entity is
4294 interoperable. If a Fortran entity is interoperable, an equivalent
4295 entity may be defined by means of C and the Fortran entity is said
4296 to be interoperable with the C entity. There does not have to be such
4297 an interoperating C entity."
4299 if (curr_comp
== NULL
)
4301 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4302 "and may be inaccessible by the C companion processor",
4303 derived_sym
->name
, &(derived_sym
->declared_at
));
4304 derived_sym
->ts
.is_c_interop
= 1;
4305 derived_sym
->attr
.is_bind_c
= 1;
4310 /* Initialize the derived type as being C interoperable.
4311 If we find an error in the components, this will be set false. */
4312 derived_sym
->ts
.is_c_interop
= 1;
4314 /* Loop through the list of components to verify that the kind of
4315 each is a C interoperable type. */
4318 /* The components cannot be pointers (fortran sense).
4319 J3/04-007, Section 15.2.3, C1505. */
4320 if (curr_comp
->attr
.pointer
!= 0)
4322 gfc_error ("Component %qs at %L cannot have the "
4323 "POINTER attribute because it is a member "
4324 "of the BIND(C) derived type %qs at %L",
4325 curr_comp
->name
, &(curr_comp
->loc
),
4326 derived_sym
->name
, &(derived_sym
->declared_at
));
4330 if (curr_comp
->attr
.proc_pointer
!= 0)
4332 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4333 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4334 &curr_comp
->loc
, derived_sym
->name
,
4335 &derived_sym
->declared_at
);
4339 /* The components cannot be allocatable.
4340 J3/04-007, Section 15.2.3, C1505. */
4341 if (curr_comp
->attr
.allocatable
!= 0)
4343 gfc_error ("Component %qs at %L cannot have the "
4344 "ALLOCATABLE attribute because it is a member "
4345 "of the BIND(C) derived type %qs at %L",
4346 curr_comp
->name
, &(curr_comp
->loc
),
4347 derived_sym
->name
, &(derived_sym
->declared_at
));
4351 /* BIND(C) derived types must have interoperable components. */
4352 if (curr_comp
->ts
.type
== BT_DERIVED
4353 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4354 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4356 /* This should be allowed; the draft says a derived-type can not
4357 have type parameters if it is has the BIND attribute. Type
4358 parameters seem to be for making parameterized derived types.
4359 There's no need to verify the type if it is c_ptr/c_funptr. */
4360 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4364 /* Grab the typespec for the given component and test the kind. */
4365 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4369 /* Report warning and continue since not fatal. The
4370 draft does specify a constraint that requires all fields
4371 to interoperate, but if the user says real(4), etc., it
4372 may interoperate with *something* in C, but the compiler
4373 most likely won't know exactly what. Further, it may not
4374 interoperate with the same data type(s) in C if the user
4375 recompiles with different flags (e.g., -m32 and -m64 on
4376 x86_64 and using integer(4) to claim interop with a
4378 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4379 /* If the derived type is bind(c), all fields must be
4381 gfc_warning (OPT_Wc_binding_type
,
4382 "Component %qs in derived type %qs at %L "
4383 "may not be C interoperable, even though "
4384 "derived type %qs is BIND(C)",
4385 curr_comp
->name
, derived_sym
->name
,
4386 &(curr_comp
->loc
), derived_sym
->name
);
4387 else if (warn_c_binding_type
)
4388 /* If derived type is param to bind(c) routine, or to one
4389 of the iso_c_binding procs, it must be interoperable, so
4390 all fields must interop too. */
4391 gfc_warning (OPT_Wc_binding_type
,
4392 "Component %qs in derived type %qs at %L "
4393 "may not be C interoperable",
4394 curr_comp
->name
, derived_sym
->name
,
4399 curr_comp
= curr_comp
->next
;
4400 } while (curr_comp
!= NULL
);
4403 /* Make sure we don't have conflicts with the attributes. */
4404 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
4406 gfc_error ("Derived type %qs at %L cannot be declared with both "
4407 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
4408 &(derived_sym
->declared_at
));
4412 if (derived_sym
->attr
.sequence
!= 0)
4414 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4415 "attribute because it is BIND(C)", derived_sym
->name
,
4416 &(derived_sym
->declared_at
));
4420 /* Mark the derived type as not being C interoperable if we found an
4421 error. If there were only warnings, proceed with the assumption
4422 it's interoperable. */
4424 derived_sym
->ts
.is_c_interop
= 0;
4430 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4433 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4437 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4438 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4440 tmp_sym
->attr
.is_c_interop
= 1;
4441 tmp_sym
->attr
.is_bind_c
= 1;
4442 tmp_sym
->ts
.is_c_interop
= 1;
4443 tmp_sym
->ts
.is_iso_c
= 1;
4444 tmp_sym
->ts
.type
= BT_DERIVED
;
4445 tmp_sym
->ts
.f90_type
= BT_VOID
;
4446 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4447 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4449 /* Set the c_address field of c_null_ptr and c_null_funptr to
4450 the value of NULL. */
4451 tmp_sym
->value
= gfc_get_expr ();
4452 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4453 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4454 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4455 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4456 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4457 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4458 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4459 c
->expr
->ts
.is_iso_c
= 1;
4465 /* Add a formal argument, gfc_formal_arglist, to the
4466 end of the given list of arguments. Set the reference to the
4467 provided symbol, param_sym, in the argument. */
4470 add_formal_arg (gfc_formal_arglist
**head
,
4471 gfc_formal_arglist
**tail
,
4472 gfc_formal_arglist
*formal_arg
,
4473 gfc_symbol
*param_sym
)
4475 /* Put in list, either as first arg or at the tail (curr arg). */
4477 *head
= *tail
= formal_arg
;
4480 (*tail
)->next
= formal_arg
;
4481 (*tail
) = formal_arg
;
4484 (*tail
)->sym
= param_sym
;
4485 (*tail
)->next
= NULL
;
4491 /* Add a procedure interface to the given symbol (i.e., store a
4492 reference to the list of formal arguments). */
4495 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4498 sym
->formal
= formal
;
4499 sym
->attr
.if_source
= source
;
4503 /* Copy the formal args from an existing symbol, src, into a new
4504 symbol, dest. New formal args are created, and the description of
4505 each arg is set according to the existing ones. This function is
4506 used when creating procedure declaration variables from a procedure
4507 declaration statement (see match_proc_decl()) to create the formal
4508 args based on the args of a given named interface.
4510 When an actual argument list is provided, skip the absent arguments.
4511 To be used together with gfc_se->ignore_optional. */
4514 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4515 gfc_actual_arglist
*actual
)
4517 gfc_formal_arglist
*head
= NULL
;
4518 gfc_formal_arglist
*tail
= NULL
;
4519 gfc_formal_arglist
*formal_arg
= NULL
;
4520 gfc_intrinsic_arg
*curr_arg
= NULL
;
4521 gfc_formal_arglist
*formal_prev
= NULL
;
4522 gfc_actual_arglist
*act_arg
= actual
;
4523 /* Save current namespace so we can change it for formal args. */
4524 gfc_namespace
*parent_ns
= gfc_current_ns
;
4526 /* Create a new namespace, which will be the formal ns (namespace
4527 of the formal args). */
4528 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4529 gfc_current_ns
->proc_name
= dest
;
4531 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4533 /* Skip absent arguments. */
4536 gcc_assert (act_arg
!= NULL
);
4537 if (act_arg
->expr
== NULL
)
4539 act_arg
= act_arg
->next
;
4542 act_arg
= act_arg
->next
;
4544 formal_arg
= gfc_get_formal_arglist ();
4545 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4547 /* May need to copy more info for the symbol. */
4548 formal_arg
->sym
->ts
= curr_arg
->ts
;
4549 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4550 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4551 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4552 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4553 formal_arg
->sym
->attr
.dummy
= 1;
4555 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4556 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4558 /* If this isn't the first arg, set up the next ptr. For the
4559 last arg built, the formal_arg->next will never get set to
4560 anything other than NULL. */
4561 if (formal_prev
!= NULL
)
4562 formal_prev
->next
= formal_arg
;
4564 formal_arg
->next
= NULL
;
4566 formal_prev
= formal_arg
;
4568 /* Add arg to list of formal args. */
4569 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4571 /* Validate changes. */
4572 gfc_commit_symbol (formal_arg
->sym
);
4575 /* Add the interface to the symbol. */
4576 add_proc_interface (dest
, IFSRC_DECL
, head
);
4578 /* Store the formal namespace information. */
4579 if (dest
->formal
!= NULL
)
4580 /* The current ns should be that for the dest proc. */
4581 dest
->formal_ns
= gfc_current_ns
;
4582 /* Restore the current namespace to what it was on entry. */
4583 gfc_current_ns
= parent_ns
;
4588 std_for_isocbinding_symbol (int id
)
4592 #define NAMED_INTCST(a,b,c,d) \
4595 #include "iso-c-binding.def"
4598 #define NAMED_FUNCTION(a,b,c,d) \
4601 #define NAMED_SUBROUTINE(a,b,c,d) \
4604 #include "iso-c-binding.def"
4605 #undef NAMED_FUNCTION
4606 #undef NAMED_SUBROUTINE
4609 return GFC_STD_F2003
;
4613 /* Generate the given set of C interoperable kind objects, or all
4614 interoperable kinds. This function will only be given kind objects
4615 for valid iso_c_binding defined types because this is verified when
4616 the 'use' statement is parsed. If the user gives an 'only' clause,
4617 the specific kinds are looked up; if they don't exist, an error is
4618 reported. If the user does not give an 'only' clause, all
4619 iso_c_binding symbols are generated. If a list of specific kinds
4620 is given, it must have a NULL in the first empty spot to mark the
4621 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4622 point to the symtree for c_(fun)ptr. */
4625 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4626 const char *local_name
, gfc_symtree
*dt_symtree
,
4629 const char *const name
= (local_name
&& local_name
[0])
4630 ? local_name
: c_interop_kinds_table
[s
].name
;
4631 gfc_symtree
*tmp_symtree
;
4632 gfc_symbol
*tmp_sym
= NULL
;
4635 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4638 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4640 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4641 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4642 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4645 /* Already exists in this scope so don't re-add it. */
4646 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4647 && (!tmp_sym
->attr
.generic
4648 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4649 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4651 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4652 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4654 gfc_dt_list
*dt_list
;
4655 dt_list
= gfc_get_dt_list ();
4656 dt_list
->derived
= tmp_sym
;
4657 dt_list
->next
= gfc_derived_types
;
4658 gfc_derived_types
= dt_list
;
4664 /* Create the sym tree in the current ns. */
4667 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4668 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4670 /* Add to the list of tentative symbols. */
4671 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4672 tmp_sym
->old_symbol
= NULL
;
4674 tmp_sym
->gfc_new
= 1;
4676 tmp_symtree
->n
.sym
= tmp_sym
;
4681 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4682 gcc_assert (tmp_symtree
);
4683 tmp_sym
= tmp_symtree
->n
.sym
;
4686 /* Say what module this symbol belongs to. */
4687 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4688 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4689 tmp_sym
->intmod_sym_id
= s
;
4690 tmp_sym
->attr
.is_iso_c
= 1;
4691 tmp_sym
->attr
.use_assoc
= 1;
4693 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4694 || s
== ISOCBINDING_NULL_PTR
);
4699 #define NAMED_INTCST(a,b,c,d) case a :
4700 #define NAMED_REALCST(a,b,c,d) case a :
4701 #define NAMED_CMPXCST(a,b,c,d) case a :
4702 #define NAMED_LOGCST(a,b,c) case a :
4703 #define NAMED_CHARKNDCST(a,b,c) case a :
4704 #include "iso-c-binding.def"
4706 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4707 c_interop_kinds_table
[s
].value
);
4709 /* Initialize an integer constant expression node. */
4710 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4711 tmp_sym
->ts
.type
= BT_INTEGER
;
4712 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4714 /* Mark this type as a C interoperable one. */
4715 tmp_sym
->ts
.is_c_interop
= 1;
4716 tmp_sym
->ts
.is_iso_c
= 1;
4717 tmp_sym
->value
->ts
.is_c_interop
= 1;
4718 tmp_sym
->value
->ts
.is_iso_c
= 1;
4719 tmp_sym
->attr
.is_c_interop
= 1;
4721 /* Tell what f90 type this c interop kind is valid. */
4722 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4727 #define NAMED_CHARCST(a,b,c) case a :
4728 #include "iso-c-binding.def"
4730 /* Initialize an integer constant expression node for the
4731 length of the character. */
4732 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4733 &gfc_current_locus
, NULL
, 1);
4734 tmp_sym
->value
->ts
.is_c_interop
= 1;
4735 tmp_sym
->value
->ts
.is_iso_c
= 1;
4736 tmp_sym
->value
->value
.character
.length
= 1;
4737 tmp_sym
->value
->value
.character
.string
[0]
4738 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4739 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4740 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4743 /* May not need this in both attr and ts, but do need in
4744 attr for writing module file. */
4745 tmp_sym
->attr
.is_c_interop
= 1;
4747 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4748 tmp_sym
->ts
.type
= BT_CHARACTER
;
4750 /* Need to set it to the C_CHAR kind. */
4751 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4753 /* Mark this type as a C interoperable one. */
4754 tmp_sym
->ts
.is_c_interop
= 1;
4755 tmp_sym
->ts
.is_iso_c
= 1;
4757 /* Tell what f90 type this c interop kind is valid. */
4758 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4762 case ISOCBINDING_PTR
:
4763 case ISOCBINDING_FUNPTR
:
4766 gfc_dt_list
**dt_list_ptr
= NULL
;
4767 gfc_component
*tmp_comp
= NULL
;
4769 /* Generate real derived type. */
4774 const char *hidden_name
;
4775 gfc_interface
*intr
, *head
;
4777 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4778 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4780 gcc_assert (tmp_symtree
== NULL
);
4781 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4782 dt_sym
= tmp_symtree
->n
.sym
;
4783 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4784 ? "c_ptr" : "c_funptr");
4786 /* Generate an artificial generic function. */
4787 head
= tmp_sym
->generic
;
4788 intr
= gfc_get_interface ();
4790 intr
->where
= gfc_current_locus
;
4792 tmp_sym
->generic
= intr
;
4794 if (!tmp_sym
->attr
.generic
4795 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4798 if (!tmp_sym
->attr
.function
4799 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4803 /* Say what module this symbol belongs to. */
4804 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4805 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4806 dt_sym
->intmod_sym_id
= s
;
4807 dt_sym
->attr
.use_assoc
= 1;
4809 /* Initialize an integer constant expression node. */
4810 dt_sym
->attr
.flavor
= FL_DERIVED
;
4811 dt_sym
->ts
.is_c_interop
= 1;
4812 dt_sym
->attr
.is_c_interop
= 1;
4813 dt_sym
->attr
.private_comp
= 1;
4814 dt_sym
->component_access
= ACCESS_PRIVATE
;
4815 dt_sym
->ts
.is_iso_c
= 1;
4816 dt_sym
->ts
.type
= BT_DERIVED
;
4817 dt_sym
->ts
.f90_type
= BT_VOID
;
4819 /* A derived type must have the bind attribute to be
4820 interoperable (J3/04-007, Section 15.2.3), even though
4821 the binding label is not used. */
4822 dt_sym
->attr
.is_bind_c
= 1;
4824 dt_sym
->attr
.referenced
= 1;
4825 dt_sym
->ts
.u
.derived
= dt_sym
;
4827 /* Add the symbol created for the derived type to the current ns. */
4828 dt_list_ptr
= &(gfc_derived_types
);
4829 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4830 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4832 /* There is already at least one derived type in the list, so append
4833 the one we're currently building for c_ptr or c_funptr. */
4834 if (*dt_list_ptr
!= NULL
)
4835 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4836 (*dt_list_ptr
) = gfc_get_dt_list ();
4837 (*dt_list_ptr
)->derived
= dt_sym
;
4838 (*dt_list_ptr
)->next
= NULL
;
4840 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4841 if (tmp_comp
== NULL
)
4844 tmp_comp
->ts
.type
= BT_INTEGER
;
4846 /* Set this because the module will need to read/write this field. */
4847 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4849 /* The kinds for c_ptr and c_funptr are the same. */
4850 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4851 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4852 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4854 /* Mark the component as C interoperable. */
4855 tmp_comp
->ts
.is_c_interop
= 1;
4860 case ISOCBINDING_NULL_PTR
:
4861 case ISOCBINDING_NULL_FUNPTR
:
4862 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4868 gfc_commit_symbol (tmp_sym
);
4873 /* Check that a symbol is already typed. If strict is not set, an untyped
4874 symbol is acceptable for non-standard-conforming mode. */
4877 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4878 bool strict
, locus where
)
4882 if (gfc_matching_prefix
)
4885 /* Check for the type and try to give it an implicit one. */
4886 if (sym
->ts
.type
== BT_UNKNOWN
4887 && !gfc_set_default_type (sym
, 0, ns
))
4891 gfc_error ("Symbol %qs is used before it is typed at %L",
4896 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
4897 " it is typed at %L", sym
->name
, &where
))
4901 /* Everything is ok. */
4906 /* Construct a typebound-procedure structure. Those are stored in a tentative
4907 list and marked `error' until symbols are committed. */
4910 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4912 gfc_typebound_proc
*result
;
4914 result
= XCNEW (gfc_typebound_proc
);
4919 latest_undo_chgset
->tbps
.safe_push (result
);
4925 /* Get the super-type of a given derived type. */
4928 gfc_get_derived_super_type (gfc_symbol
* derived
)
4930 gcc_assert (derived
);
4932 if (derived
->attr
.generic
)
4933 derived
= gfc_find_dt_in_generic (derived
);
4935 if (!derived
->attr
.extension
)
4938 gcc_assert (derived
->components
);
4939 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4940 gcc_assert (derived
->components
->ts
.u
.derived
);
4942 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4943 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4945 return derived
->components
->ts
.u
.derived
;
4949 /* Get the ultimate super-type of a given derived type. */
4952 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4954 if (!derived
->attr
.extension
)
4957 derived
= gfc_get_derived_super_type (derived
);
4959 if (derived
->attr
.extension
)
4960 return gfc_get_ultimate_derived_super_type (derived
);
4966 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4969 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4971 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4972 t2
= gfc_get_derived_super_type (t2
);
4973 return gfc_compare_derived_types (t1
, t2
);
4977 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4978 If ts1 is nonpolymorphic, ts2 must be the same type.
4979 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4982 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4984 bool is_class1
= (ts1
->type
== BT_CLASS
);
4985 bool is_class2
= (ts2
->type
== BT_CLASS
);
4986 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4987 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4988 bool is_union1
= (ts1
->type
== BT_UNION
);
4989 bool is_union2
= (ts2
->type
== BT_UNION
);
4992 && ts1
->u
.derived
->components
4993 && ((ts1
->u
.derived
->attr
.is_class
4994 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
4995 .unlimited_polymorphic
)
4996 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
4999 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
5000 && !is_union1
&& !is_union2
)
5001 return (ts1
->type
== ts2
->type
);
5003 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
5004 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
5006 if (is_derived1
&& is_class2
)
5007 return gfc_compare_derived_types (ts1
->u
.derived
,
5008 ts2
->u
.derived
->attr
.is_class
?
5009 ts2
->u
.derived
->components
->ts
.u
.derived
5011 if (is_class1
&& is_derived2
)
5012 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5013 ts1
->u
.derived
->components
->ts
.u
.derived
5016 else if (is_class1
&& is_class2
)
5017 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
5018 ts1
->u
.derived
->components
->ts
.u
.derived
5020 ts2
->u
.derived
->attr
.is_class
?
5021 ts2
->u
.derived
->components
->ts
.u
.derived
5028 /* Find the parent-namespace of the current function. If we're inside
5029 BLOCK constructs, it may not be the current one. */
5032 gfc_find_proc_namespace (gfc_namespace
* ns
)
5034 while (ns
->construct_entities
)
5044 /* Check if an associate-variable should be translated as an `implicit' pointer
5045 internally (if it is associated to a variable and not an array with
5049 gfc_is_associate_pointer (gfc_symbol
* sym
)
5054 if (sym
->ts
.type
== BT_CLASS
)
5057 if (sym
->ts
.type
== BT_CHARACTER
5059 && sym
->assoc
->target
5060 && sym
->assoc
->target
->expr_type
== EXPR_FUNCTION
)
5063 if (!sym
->assoc
->variable
)
5066 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
5074 gfc_find_dt_in_generic (gfc_symbol
*sym
)
5076 gfc_interface
*intr
= NULL
;
5078 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5081 if (sym
->attr
.generic
)
5082 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5083 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5085 return intr
? intr
->sym
: NULL
;
5089 /* Get the dummy arguments from a procedure symbol. If it has been declared
5090 via a PROCEDURE statement with a named interface, ts.interface will be set
5091 and the arguments need to be taken from there. */
5093 gfc_formal_arglist
*
5094 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5096 gfc_formal_arglist
*dummies
;
5098 dummies
= sym
->formal
;
5099 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5100 dummies
= sym
->ts
.interface
->formal
;