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 if (attr
->dummy
&& ((attr
->function
|| attr
->subroutine
) &&
478 gfc_current_state () == COMP_CONTAINS
))
479 gfc_error_now ("internal procedure %qs at %L conflicts with "
480 "DUMMY argument", name
, where
);
483 conf (dummy
, intrinsic
);
484 conf (dummy
, threadprivate
);
485 conf (dummy
, omp_declare_target
);
486 conf (dummy
, omp_declare_target_link
);
487 conf (pointer
, target
);
488 conf (pointer
, intrinsic
);
489 conf (pointer
, elemental
);
490 conf (pointer
, codimension
);
491 conf (allocatable
, elemental
);
493 conf (in_common
, automatic
);
494 conf (in_equivalence
, automatic
);
495 conf (result
, automatic
);
496 conf (use_assoc
, automatic
);
497 conf (dummy
, automatic
);
499 conf (target
, external
);
500 conf (target
, intrinsic
);
502 if (!attr
->if_source
)
503 conf (external
, dimension
); /* See Fortran 95's R504. */
505 conf (external
, intrinsic
);
506 conf (entry
, intrinsic
);
508 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
509 conf (external
, subroutine
);
511 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
512 "Procedure pointer at %C"))
515 conf (allocatable
, pointer
);
516 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
517 conf_std (allocatable
, function
, GFC_STD_F2003
);
518 conf_std (allocatable
, result
, GFC_STD_F2003
);
519 conf (elemental
, recursive
);
521 conf (in_common
, dummy
);
522 conf (in_common
, allocatable
);
523 conf (in_common
, codimension
);
524 conf (in_common
, result
);
526 conf (in_equivalence
, use_assoc
);
527 conf (in_equivalence
, codimension
);
528 conf (in_equivalence
, dummy
);
529 conf (in_equivalence
, target
);
530 conf (in_equivalence
, pointer
);
531 conf (in_equivalence
, function
);
532 conf (in_equivalence
, result
);
533 conf (in_equivalence
, entry
);
534 conf (in_equivalence
, allocatable
);
535 conf (in_equivalence
, threadprivate
);
536 conf (in_equivalence
, omp_declare_target
);
537 conf (in_equivalence
, omp_declare_target_link
);
538 conf (in_equivalence
, oacc_declare_create
);
539 conf (in_equivalence
, oacc_declare_copyin
);
540 conf (in_equivalence
, oacc_declare_deviceptr
);
541 conf (in_equivalence
, oacc_declare_device_resident
);
543 conf (dummy
, result
);
544 conf (entry
, result
);
545 conf (generic
, result
);
546 conf (generic
, omp_declare_target
);
547 conf (generic
, omp_declare_target_link
);
549 conf (function
, subroutine
);
551 if (!function
&& !subroutine
)
552 conf (is_bind_c
, dummy
);
554 conf (is_bind_c
, cray_pointer
);
555 conf (is_bind_c
, cray_pointee
);
556 conf (is_bind_c
, codimension
);
557 conf (is_bind_c
, allocatable
);
558 conf (is_bind_c
, elemental
);
560 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
561 Parameter conflict caught below. Also, value cannot be specified
562 for a dummy procedure. */
564 /* Cray pointer/pointee conflicts. */
565 conf (cray_pointer
, cray_pointee
);
566 conf (cray_pointer
, dimension
);
567 conf (cray_pointer
, codimension
);
568 conf (cray_pointer
, contiguous
);
569 conf (cray_pointer
, pointer
);
570 conf (cray_pointer
, target
);
571 conf (cray_pointer
, allocatable
);
572 conf (cray_pointer
, external
);
573 conf (cray_pointer
, intrinsic
);
574 conf (cray_pointer
, in_namelist
);
575 conf (cray_pointer
, function
);
576 conf (cray_pointer
, subroutine
);
577 conf (cray_pointer
, entry
);
579 conf (cray_pointee
, allocatable
);
580 conf (cray_pointee
, contiguous
);
581 conf (cray_pointee
, codimension
);
582 conf (cray_pointee
, intent
);
583 conf (cray_pointee
, optional
);
584 conf (cray_pointee
, dummy
);
585 conf (cray_pointee
, target
);
586 conf (cray_pointee
, intrinsic
);
587 conf (cray_pointee
, pointer
);
588 conf (cray_pointee
, entry
);
589 conf (cray_pointee
, in_common
);
590 conf (cray_pointee
, in_equivalence
);
591 conf (cray_pointee
, threadprivate
);
592 conf (cray_pointee
, omp_declare_target
);
593 conf (cray_pointee
, omp_declare_target_link
);
594 conf (cray_pointee
, oacc_declare_create
);
595 conf (cray_pointee
, oacc_declare_copyin
);
596 conf (cray_pointee
, oacc_declare_deviceptr
);
597 conf (cray_pointee
, oacc_declare_device_resident
);
600 conf (data
, function
);
602 conf (data
, allocatable
);
604 conf (value
, pointer
)
605 conf (value
, allocatable
)
606 conf (value
, subroutine
)
607 conf (value
, function
)
608 conf (value
, volatile_
)
609 conf (value
, dimension
)
610 conf (value
, codimension
)
611 conf (value
, external
)
613 conf (codimension
, result
)
616 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
619 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
623 conf (is_protected
, intrinsic
)
624 conf (is_protected
, in_common
)
626 conf (asynchronous
, intrinsic
)
627 conf (asynchronous
, external
)
629 conf (volatile_
, intrinsic
)
630 conf (volatile_
, external
)
632 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
639 conf (procedure
, allocatable
)
640 conf (procedure
, dimension
)
641 conf (procedure
, codimension
)
642 conf (procedure
, intrinsic
)
643 conf (procedure
, target
)
644 conf (procedure
, value
)
645 conf (procedure
, volatile_
)
646 conf (procedure
, asynchronous
)
647 conf (procedure
, entry
)
649 conf (proc_pointer
, abstract
)
650 conf (proc_pointer
, omp_declare_target
)
651 conf (proc_pointer
, omp_declare_target_link
)
653 conf (entry
, omp_declare_target
)
654 conf (entry
, omp_declare_target_link
)
655 conf (entry
, oacc_declare_create
)
656 conf (entry
, oacc_declare_copyin
)
657 conf (entry
, oacc_declare_deviceptr
)
658 conf (entry
, oacc_declare_device_resident
)
660 a1
= gfc_code2string (flavors
, attr
->flavor
);
662 if (attr
->in_namelist
663 && attr
->flavor
!= FL_VARIABLE
664 && attr
->flavor
!= FL_PROCEDURE
665 && attr
->flavor
!= FL_UNKNOWN
)
671 switch (attr
->flavor
)
681 conf2 (asynchronous
);
684 conf2 (is_protected
);
694 conf2 (threadprivate
);
695 conf2 (omp_declare_target
);
696 conf2 (omp_declare_target_link
);
697 conf2 (oacc_declare_create
);
698 conf2 (oacc_declare_copyin
);
699 conf2 (oacc_declare_deviceptr
);
700 conf2 (oacc_declare_device_resident
);
702 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
704 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
705 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
712 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
726 /* Conflicts with INTENT, SAVE and RESULT will be checked
727 at resolution stage, see "resolve_fl_procedure". */
729 if (attr
->subroutine
)
735 conf2 (asynchronous
);
740 if (!attr
->proc_pointer
)
741 conf2 (threadprivate
);
744 if (!attr
->proc_pointer
)
747 conf2 (omp_declare_target_link
);
751 case PROC_ST_FUNCTION
:
762 conf2 (threadprivate
);
782 conf2 (threadprivate
);
784 conf2 (omp_declare_target
);
785 conf2 (omp_declare_target_link
);
786 conf2 (oacc_declare_create
);
787 conf2 (oacc_declare_copyin
);
788 conf2 (oacc_declare_deviceptr
);
789 conf2 (oacc_declare_device_resident
);
791 if (attr
->intent
!= INTENT_UNKNOWN
)
808 conf2 (is_protected
);
814 conf2 (asynchronous
);
815 conf2 (threadprivate
);
831 gfc_error ("%s attribute conflicts with %s attribute at %L",
834 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
835 a1
, a2
, name
, where
);
842 return gfc_notify_std (standard
, "%s attribute "
843 "with %s attribute at %L", a1
, a2
,
848 return gfc_notify_std (standard
, "%s attribute "
849 "with %s attribute in %qs at %L",
850 a1
, a2
, name
, where
);
859 /* Mark a symbol as referenced. */
862 gfc_set_sym_referenced (gfc_symbol
*sym
)
865 if (sym
->attr
.referenced
)
868 sym
->attr
.referenced
= 1;
870 /* Remember which order dummy variables are accessed in. */
872 sym
->dummy_order
= next_dummy_order
++;
876 /* Common subroutine called by attribute changing subroutines in order
877 to prevent them from changing a symbol that has been
878 use-associated. Returns zero if it is OK to change the symbol,
882 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
885 if (attr
->use_assoc
== 0)
889 where
= &gfc_current_locus
;
892 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
895 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
902 /* Generate an error because of a duplicate attribute. */
905 duplicate_attr (const char *attr
, locus
*where
)
909 where
= &gfc_current_locus
;
911 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
916 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
917 locus
*where ATTRIBUTE_UNUSED
)
919 attr
->ext_attr
|= 1 << ext_attr
;
924 /* Called from decl.c (attr_decl1) to check attributes, when declared
928 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
930 if (check_used (attr
, NULL
, where
))
933 return check_conflict (attr
, NULL
, where
);
938 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
941 if (check_used (attr
, NULL
, where
))
944 if (attr
->allocatable
)
946 duplicate_attr ("ALLOCATABLE", where
);
950 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
951 && !gfc_find_state (COMP_INTERFACE
))
953 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
958 attr
->allocatable
= 1;
959 return check_conflict (attr
, NULL
, where
);
964 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
966 if (check_used (attr
, name
, where
))
969 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
970 "Duplicate AUTOMATIC attribute specified at %L", where
))
974 return check_conflict (attr
, name
, where
);
979 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
982 if (check_used (attr
, name
, where
))
985 if (attr
->codimension
)
987 duplicate_attr ("CODIMENSION", where
);
991 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
992 && !gfc_find_state (COMP_INTERFACE
))
994 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
995 "at %L", name
, where
);
999 attr
->codimension
= 1;
1000 return check_conflict (attr
, name
, where
);
1005 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
1008 if (check_used (attr
, name
, where
))
1011 if (attr
->dimension
)
1013 duplicate_attr ("DIMENSION", where
);
1017 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1018 && !gfc_find_state (COMP_INTERFACE
))
1020 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1021 "at %L", name
, where
);
1025 attr
->dimension
= 1;
1026 return check_conflict (attr
, name
, where
);
1031 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1034 if (check_used (attr
, name
, where
))
1037 attr
->contiguous
= 1;
1038 return check_conflict (attr
, name
, where
);
1043 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1046 if (check_used (attr
, NULL
, where
))
1051 duplicate_attr ("EXTERNAL", where
);
1055 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1058 attr
->proc_pointer
= 1;
1063 return check_conflict (attr
, NULL
, where
);
1068 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1071 if (check_used (attr
, NULL
, where
))
1074 if (attr
->intrinsic
)
1076 duplicate_attr ("INTRINSIC", where
);
1080 attr
->intrinsic
= 1;
1082 return check_conflict (attr
, NULL
, where
);
1087 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1090 if (check_used (attr
, NULL
, where
))
1095 duplicate_attr ("OPTIONAL", where
);
1100 return check_conflict (attr
, NULL
, where
);
1105 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1108 if (check_used (attr
, NULL
, where
))
1111 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1112 && !gfc_find_state (COMP_INTERFACE
)))
1114 duplicate_attr ("POINTER", where
);
1118 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1119 || (attr
->if_source
== IFSRC_IFBODY
1120 && !gfc_find_state (COMP_INTERFACE
)))
1121 attr
->proc_pointer
= 1;
1125 return check_conflict (attr
, NULL
, where
);
1130 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1133 if (check_used (attr
, NULL
, where
))
1136 attr
->cray_pointer
= 1;
1137 return check_conflict (attr
, NULL
, where
);
1142 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1145 if (check_used (attr
, NULL
, where
))
1148 if (attr
->cray_pointee
)
1150 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1151 " statements", where
);
1155 attr
->cray_pointee
= 1;
1156 return check_conflict (attr
, NULL
, where
);
1161 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1163 if (check_used (attr
, name
, where
))
1166 if (attr
->is_protected
)
1168 if (!gfc_notify_std (GFC_STD_LEGACY
,
1169 "Duplicate PROTECTED attribute specified at %L",
1174 attr
->is_protected
= 1;
1175 return check_conflict (attr
, name
, where
);
1180 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1183 if (check_used (attr
, name
, where
))
1187 return check_conflict (attr
, name
, where
);
1192 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1196 if (check_used (attr
, name
, where
))
1199 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1202 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1207 if (s
== SAVE_EXPLICIT
)
1208 gfc_unset_implicit_pure (NULL
);
1210 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1212 if (!gfc_notify_std (GFC_STD_LEGACY
,
1213 "Duplicate SAVE attribute specified at %L",
1219 return check_conflict (attr
, name
, where
);
1224 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1227 if (check_used (attr
, name
, where
))
1232 if (!gfc_notify_std (GFC_STD_LEGACY
,
1233 "Duplicate VALUE attribute specified at %L",
1239 return check_conflict (attr
, name
, where
);
1244 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1246 /* No check_used needed as 11.2.1 of the F2003 standard allows
1247 that the local identifier made accessible by a use statement can be
1248 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1250 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1251 if (!gfc_notify_std (GFC_STD_LEGACY
,
1252 "Duplicate VOLATILE attribute specified at %L",
1256 attr
->volatile_
= 1;
1257 attr
->volatile_ns
= gfc_current_ns
;
1258 return check_conflict (attr
, name
, where
);
1263 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1265 /* No check_used needed as 11.2.1 of the F2003 standard allows
1266 that the local identifier made accessible by a use statement can be
1267 given a ASYNCHRONOUS attribute. */
1269 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1270 if (!gfc_notify_std (GFC_STD_LEGACY
,
1271 "Duplicate ASYNCHRONOUS attribute specified at %L",
1275 attr
->asynchronous
= 1;
1276 attr
->asynchronous_ns
= gfc_current_ns
;
1277 return check_conflict (attr
, name
, where
);
1282 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1285 if (check_used (attr
, name
, where
))
1288 if (attr
->threadprivate
)
1290 duplicate_attr ("THREADPRIVATE", where
);
1294 attr
->threadprivate
= 1;
1295 return check_conflict (attr
, name
, where
);
1300 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1304 if (check_used (attr
, name
, where
))
1307 if (attr
->omp_declare_target
)
1310 attr
->omp_declare_target
= 1;
1311 return check_conflict (attr
, name
, where
);
1316 gfc_add_omp_declare_target_link (symbol_attribute
*attr
, const char *name
,
1320 if (check_used (attr
, name
, where
))
1323 if (attr
->omp_declare_target_link
)
1326 attr
->omp_declare_target_link
= 1;
1327 return check_conflict (attr
, name
, where
);
1332 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1335 if (check_used (attr
, name
, where
))
1338 if (attr
->oacc_declare_create
)
1341 attr
->oacc_declare_create
= 1;
1342 return check_conflict (attr
, name
, where
);
1347 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1350 if (check_used (attr
, name
, where
))
1353 if (attr
->oacc_declare_copyin
)
1356 attr
->oacc_declare_copyin
= 1;
1357 return check_conflict (attr
, name
, where
);
1362 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1365 if (check_used (attr
, name
, where
))
1368 if (attr
->oacc_declare_deviceptr
)
1371 attr
->oacc_declare_deviceptr
= 1;
1372 return check_conflict (attr
, name
, where
);
1377 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1380 if (check_used (attr
, name
, where
))
1383 if (attr
->oacc_declare_device_resident
)
1386 attr
->oacc_declare_device_resident
= 1;
1387 return check_conflict (attr
, name
, where
);
1392 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1395 if (check_used (attr
, NULL
, where
))
1400 duplicate_attr ("TARGET", where
);
1405 return check_conflict (attr
, NULL
, where
);
1410 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1413 if (check_used (attr
, name
, where
))
1416 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1418 return check_conflict (attr
, name
, where
);
1423 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1426 if (check_used (attr
, name
, where
))
1429 /* Duplicate attribute already checked for. */
1430 attr
->in_common
= 1;
1431 return check_conflict (attr
, name
, where
);
1436 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1439 /* Duplicate attribute already checked for. */
1440 attr
->in_equivalence
= 1;
1441 if (!check_conflict (attr
, name
, where
))
1444 if (attr
->flavor
== FL_VARIABLE
)
1447 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1452 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1455 if (check_used (attr
, name
, where
))
1459 return check_conflict (attr
, name
, where
);
1464 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1467 attr
->in_namelist
= 1;
1468 return check_conflict (attr
, name
, where
);
1473 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1476 if (check_used (attr
, name
, where
))
1480 return check_conflict (attr
, name
, where
);
1485 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1488 if (check_used (attr
, NULL
, where
))
1491 if (attr
->elemental
)
1493 duplicate_attr ("ELEMENTAL", where
);
1497 attr
->elemental
= 1;
1498 return check_conflict (attr
, NULL
, where
);
1503 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1506 if (check_used (attr
, NULL
, where
))
1511 duplicate_attr ("PURE", where
);
1516 return check_conflict (attr
, NULL
, where
);
1521 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1524 if (check_used (attr
, NULL
, where
))
1527 if (attr
->recursive
)
1529 duplicate_attr ("RECURSIVE", where
);
1533 attr
->recursive
= 1;
1534 return check_conflict (attr
, NULL
, where
);
1539 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1542 if (check_used (attr
, name
, where
))
1547 duplicate_attr ("ENTRY", where
);
1552 return check_conflict (attr
, name
, where
);
1557 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1560 if (attr
->flavor
!= FL_PROCEDURE
1561 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1565 return check_conflict (attr
, name
, where
);
1570 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1573 if (attr
->flavor
!= FL_PROCEDURE
1574 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1577 attr
->subroutine
= 1;
1578 return check_conflict (attr
, name
, where
);
1583 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1586 if (attr
->flavor
!= FL_PROCEDURE
1587 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1591 return check_conflict (attr
, name
, where
);
1596 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1599 if (check_used (attr
, NULL
, where
))
1602 if (attr
->flavor
!= FL_PROCEDURE
1603 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1606 if (attr
->procedure
)
1608 duplicate_attr ("PROCEDURE", where
);
1612 attr
->procedure
= 1;
1614 return check_conflict (attr
, NULL
, where
);
1619 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1623 duplicate_attr ("ABSTRACT", where
);
1629 return check_conflict (attr
, NULL
, where
);
1633 /* Flavors are special because some flavors are not what Fortran
1634 considers attributes and can be reaffirmed multiple times. */
1637 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1641 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1642 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1643 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1646 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1649 if (attr
->flavor
!= FL_UNKNOWN
)
1652 where
= &gfc_current_locus
;
1655 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1656 gfc_code2string (flavors
, attr
->flavor
), name
,
1657 gfc_code2string (flavors
, f
), where
);
1659 gfc_error ("%s attribute conflicts with %s attribute at %L",
1660 gfc_code2string (flavors
, attr
->flavor
),
1661 gfc_code2string (flavors
, f
), where
);
1668 return check_conflict (attr
, name
, where
);
1673 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1674 const char *name
, locus
*where
)
1677 if (check_used (attr
, name
, where
))
1680 if (attr
->flavor
!= FL_PROCEDURE
1681 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1685 where
= &gfc_current_locus
;
1687 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
)
1689 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1690 && !gfc_notification_std (GFC_STD_F2008
))
1691 gfc_error ("%s procedure at %L is already declared as %s "
1692 "procedure. \nF2008: A pointer function assignment "
1693 "is ambiguous if it is the first executable statement "
1694 "after the specification block. Please add any other "
1695 "kind of executable statement before it. FIXME",
1696 gfc_code2string (procedures
, t
), where
,
1697 gfc_code2string (procedures
, attr
->proc
));
1699 gfc_error ("%s procedure at %L is already declared as %s "
1700 "procedure", gfc_code2string (procedures
, t
), where
,
1701 gfc_code2string (procedures
, attr
->proc
));
1708 /* Statement functions are always scalar and functions. */
1709 if (t
== PROC_ST_FUNCTION
1710 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1711 || attr
->dimension
))
1714 return check_conflict (attr
, name
, where
);
1719 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1722 if (check_used (attr
, NULL
, where
))
1725 if (attr
->intent
== INTENT_UNKNOWN
)
1727 attr
->intent
= intent
;
1728 return check_conflict (attr
, NULL
, where
);
1732 where
= &gfc_current_locus
;
1734 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1735 gfc_intent_string (attr
->intent
),
1736 gfc_intent_string (intent
), where
);
1742 /* No checks for use-association in public and private statements. */
1745 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1746 const char *name
, locus
*where
)
1749 if (attr
->access
== ACCESS_UNKNOWN
1750 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1752 attr
->access
= access
;
1753 return check_conflict (attr
, name
, where
);
1757 where
= &gfc_current_locus
;
1758 gfc_error ("ACCESS specification at %L was already specified", where
);
1764 /* Set the is_bind_c field for the given symbol_attribute. */
1767 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1768 int is_proc_lang_bind_spec
)
1771 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1772 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1773 "variables or common blocks", where
);
1774 else if (attr
->is_bind_c
)
1775 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1777 attr
->is_bind_c
= 1;
1780 where
= &gfc_current_locus
;
1782 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1785 return check_conflict (attr
, name
, where
);
1789 /* Set the extension field for the given symbol_attribute. */
1792 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1795 where
= &gfc_current_locus
;
1797 if (attr
->extension
)
1798 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1800 attr
->extension
= 1;
1802 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1810 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1811 gfc_formal_arglist
* formal
, locus
*where
)
1813 if (check_used (&sym
->attr
, sym
->name
, where
))
1816 /* Skip the following checks in the case of a module_procedures in a
1817 submodule since they will manifestly fail. */
1818 if (sym
->attr
.module_procedure
== 1
1819 && source
== IFSRC_DECL
)
1823 where
= &gfc_current_locus
;
1825 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1826 && sym
->attr
.if_source
!= IFSRC_DECL
)
1828 gfc_error ("Symbol %qs at %L already has an explicit interface",
1833 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1835 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1836 "body", sym
->name
, where
);
1841 sym
->formal
= formal
;
1842 sym
->attr
.if_source
= source
;
1848 /* Add a type to a symbol. */
1851 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1857 where
= &gfc_current_locus
;
1860 type
= sym
->result
->ts
.type
;
1862 type
= sym
->ts
.type
;
1864 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1865 type
= sym
->ns
->proc_name
->ts
.type
;
1867 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1868 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1869 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
1870 && !sym
->attr
.module_procedure
)
1872 if (sym
->attr
.use_assoc
)
1873 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
1874 "use-associated at %L", sym
->name
, where
, sym
->module
,
1877 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
1878 where
, gfc_basic_typename (type
));
1882 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1884 gfc_error ("Procedure %qs at %L may not have basic type of %s",
1885 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1889 flavor
= sym
->attr
.flavor
;
1891 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1892 || flavor
== FL_LABEL
1893 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1894 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1896 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
1905 /* Clears all attributes. */
1908 gfc_clear_attr (symbol_attribute
*attr
)
1910 memset (attr
, 0, sizeof (symbol_attribute
));
1914 /* Check for missing attributes in the new symbol. Currently does
1915 nothing, but it's not clear that it is unnecessary yet. */
1918 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1919 locus
*where ATTRIBUTE_UNUSED
)
1926 /* Copy an attribute to a symbol attribute, bit by bit. Some
1927 attributes have a lot of side-effects but cannot be present given
1928 where we are called from, so we ignore some bits. */
1931 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1933 int is_proc_lang_bind_spec
;
1935 /* In line with the other attributes, we only add bits but do not remove
1936 them; cf. also PR 41034. */
1937 dest
->ext_attr
|= src
->ext_attr
;
1939 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
1942 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
1944 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
1946 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
1948 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
1950 if (src
->optional
&& !gfc_add_optional (dest
, where
))
1952 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
1954 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
1956 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
1958 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
1960 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
1962 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
1964 if (src
->threadprivate
1965 && !gfc_add_threadprivate (dest
, NULL
, where
))
1967 if (src
->omp_declare_target
1968 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
1970 if (src
->omp_declare_target_link
1971 && !gfc_add_omp_declare_target_link (dest
, NULL
, where
))
1973 if (src
->oacc_declare_create
1974 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
1976 if (src
->oacc_declare_copyin
1977 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
1979 if (src
->oacc_declare_deviceptr
1980 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
1982 if (src
->oacc_declare_device_resident
1983 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
1985 if (src
->target
&& !gfc_add_target (dest
, where
))
1987 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
1989 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
1994 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
1997 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
2000 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
2002 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
2004 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
2007 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
2009 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
2011 if (src
->pure
&& !gfc_add_pure (dest
, where
))
2013 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
2016 if (src
->flavor
!= FL_UNKNOWN
2017 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
2020 if (src
->intent
!= INTENT_UNKNOWN
2021 && !gfc_add_intent (dest
, src
->intent
, where
))
2024 if (src
->access
!= ACCESS_UNKNOWN
2025 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
2028 if (!gfc_missing_attr (dest
, where
))
2031 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2033 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2036 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2038 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2041 if (src
->is_c_interop
)
2042 dest
->is_c_interop
= 1;
2046 if (src
->external
&& !gfc_add_external (dest
, where
))
2048 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2050 if (src
->proc_pointer
)
2051 dest
->proc_pointer
= 1;
2060 /* A function to generate a dummy argument symbol using that from the
2061 interface declaration. Can be used for the result symbol as well if
2065 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2069 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2073 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2076 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2077 &gfc_current_locus
))
2080 if ((*dsym
)->attr
.dimension
)
2081 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2083 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2085 if ((*dsym
) != NULL
&& !result
2086 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2087 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2089 else if ((*dsym
) != NULL
&& result
2090 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2091 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2098 /************** Component name management ************/
2100 /* Component names of a derived type form their own little namespaces
2101 that are separate from all other spaces. The space is composed of
2102 a singly linked list of gfc_component structures whose head is
2103 located in the parent symbol. */
2106 /* Add a component name to a symbol. The call fails if the name is
2107 already present. On success, the component pointer is modified to
2108 point to the additional component structure. */
2111 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2112 gfc_component
**component
)
2114 gfc_component
*p
, *tail
;
2116 /* Check for existing components with the same name, but not for union
2117 components or containers. Unions and maps are anonymous so they have
2118 unique internal names which will never conflict.
2119 Don't use gfc_find_component here because it calls gfc_use_derived,
2120 but the derived type may not be fully defined yet. */
2123 for (p
= sym
->components
; p
; p
= p
->next
)
2125 if (strcmp (p
->name
, name
) == 0)
2127 gfc_error ("Component %qs at %C already declared at %L",
2135 if (sym
->attr
.extension
2136 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2137 name
, true, true, NULL
))
2139 gfc_error ("Component %qs at %C already in the parent type "
2140 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2144 /* Allocate a new component. */
2145 p
= gfc_get_component ();
2148 sym
->components
= p
;
2152 p
->name
= gfc_get_string ("%s", name
);
2153 p
->loc
= gfc_current_locus
;
2154 p
->ts
.type
= BT_UNKNOWN
;
2161 /* Recursive function to switch derived types of all symbol in a
2165 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2173 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2174 sym
->ts
.u
.derived
= to
;
2176 switch_types (st
->left
, from
, to
);
2177 switch_types (st
->right
, from
, to
);
2181 /* This subroutine is called when a derived type is used in order to
2182 make the final determination about which version to use. The
2183 standard requires that a type be defined before it is 'used', but
2184 such types can appear in IMPLICIT statements before the actual
2185 definition. 'Using' in this context means declaring a variable to
2186 be that type or using the type constructor.
2188 If a type is used and the components haven't been defined, then we
2189 have to have a derived type in a parent unit. We find the node in
2190 the other namespace and point the symtree node in this namespace to
2191 that node. Further reference to this name point to the correct
2192 node. If we can't find the node in a parent namespace, then we have
2195 This subroutine takes a pointer to a symbol node and returns a
2196 pointer to the translated node or NULL for an error. Usually there
2197 is no translation and we return the node we were passed. */
2200 gfc_use_derived (gfc_symbol
*sym
)
2210 if (sym
->attr
.unlimited_polymorphic
)
2213 if (sym
->attr
.generic
)
2214 sym
= gfc_find_dt_in_generic (sym
);
2216 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2217 return sym
; /* Already defined. */
2219 if (sym
->ns
->parent
== NULL
)
2222 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2224 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2228 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2231 /* Get rid of symbol sym, translating all references to s. */
2232 for (i
= 0; i
< GFC_LETTERS
; i
++)
2234 t
= &sym
->ns
->default_type
[i
];
2235 if (t
->u
.derived
== sym
)
2239 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2244 /* Unlink from list of modified symbols. */
2245 gfc_commit_symbol (sym
);
2247 switch_types (sym
->ns
->sym_root
, sym
, s
);
2249 /* TODO: Also have to replace sym -> s in other lists like
2250 namelists, common lists and interface lists. */
2251 gfc_free_symbol (sym
);
2256 gfc_error ("Derived type %qs at %C is being used before it is defined",
2262 /* Find the component with the given name in the union type symbol.
2263 If ref is not NULL it will be set to the chain of components through which
2264 the component can actually be accessed. This is necessary for unions because
2265 intermediate structures may be maps, nested structures, or other unions,
2266 all of which may (or must) be 'anonymous' to user code. */
2268 static gfc_component
*
2269 find_union_component (gfc_symbol
*un
, const char *name
,
2270 bool noaccess
, gfc_ref
**ref
)
2272 gfc_component
*m
, *check
;
2273 gfc_ref
*sref
, *tmp
;
2275 for (m
= un
->components
; m
; m
= m
->next
)
2277 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2281 /* Found component somewhere in m; chain the refs together. */
2285 sref
= gfc_get_ref ();
2286 sref
->type
= REF_COMPONENT
;
2287 sref
->u
.c
.component
= m
;
2288 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2293 /* Other checks (such as access) were done in the recursive calls. */
2300 /* Given a derived type node and a component name, try to locate the
2301 component structure. Returns the NULL pointer if the component is
2302 not found or the components are private. If noaccess is set, no access
2303 checks are done. If silent is set, an error will not be generated if
2304 the component cannot be found or accessed.
2306 If ref is not NULL, *ref is set to represent the chain of components
2307 required to get to the ultimate component.
2309 If the component is simply a direct subcomponent, or is inherited from a
2310 parent derived type in the given derived type, this is a single ref with its
2311 component set to the returned component.
2313 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2314 when the component is found through an implicit chain of nested union and
2315 map components. Unions and maps are "anonymous" substructures in FORTRAN
2316 which cannot be explicitly referenced, but the reference chain must be
2317 considered as in C for backend translation to correctly compute layouts.
2318 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2321 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2322 bool noaccess
, bool silent
, gfc_ref
**ref
)
2324 gfc_component
*p
, *check
;
2325 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2327 if (name
== NULL
|| sym
== NULL
)
2330 if (sym
->attr
.flavor
== FL_DERIVED
)
2331 sym
= gfc_use_derived (sym
);
2333 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2338 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2339 if (sym
->attr
.flavor
== FL_UNION
)
2340 return find_union_component (sym
, name
, noaccess
, ref
);
2342 if (ref
) *ref
= NULL
;
2343 for (p
= sym
->components
; p
; p
= p
->next
)
2345 /* Nest search into union's maps. */
2346 if (p
->ts
.type
== BT_UNION
)
2348 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2354 sref
= gfc_get_ref ();
2355 sref
->type
= REF_COMPONENT
;
2356 sref
->u
.c
.component
= p
;
2357 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2364 else if (strcmp (p
->name
, name
) == 0)
2370 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2372 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2373 if (p
->attr
.access
== ACCESS_PRIVATE
||
2374 (p
->attr
.access
!= ACCESS_PUBLIC
2375 && sym
->component_access
== ACCESS_PRIVATE
2376 && !is_parent_comp
))
2379 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2386 && sym
->attr
.extension
2387 && sym
->components
->ts
.type
== BT_DERIVED
)
2389 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2390 noaccess
, silent
, ref
);
2391 /* Do not overwrite the error. */
2396 if (p
== NULL
&& !silent
)
2397 gfc_error ("%qs at %C is not a member of the %qs structure",
2400 /* Component was found; build the ultimate component reference. */
2401 if (p
!= NULL
&& ref
)
2403 tmp
= gfc_get_ref ();
2404 tmp
->type
= REF_COMPONENT
;
2405 tmp
->u
.c
.component
= p
;
2407 /* Link the final component ref to the end of the chain of subrefs. */
2411 for (; sref
->next
; sref
= sref
->next
)
2423 /* Given a symbol, free all of the component structures and everything
2427 free_components (gfc_component
*p
)
2435 gfc_free_array_spec (p
->as
);
2436 gfc_free_expr (p
->initializer
);
2444 /******************** Statement label management ********************/
2446 /* Comparison function for statement labels, used for managing the
2450 compare_st_labels (void *a1
, void *b1
)
2452 int a
= ((gfc_st_label
*) a1
)->value
;
2453 int b
= ((gfc_st_label
*) b1
)->value
;
2459 /* Free a single gfc_st_label structure, making sure the tree is not
2460 messed up. This function is called only when some parse error
2464 gfc_free_st_label (gfc_st_label
*label
)
2470 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2472 if (label
->format
!= NULL
)
2473 gfc_free_expr (label
->format
);
2479 /* Free a whole tree of gfc_st_label structures. */
2482 free_st_labels (gfc_st_label
*label
)
2488 free_st_labels (label
->left
);
2489 free_st_labels (label
->right
);
2491 if (label
->format
!= NULL
)
2492 gfc_free_expr (label
->format
);
2497 /* Given a label number, search for and return a pointer to the label
2498 structure, creating it if it does not exist. */
2501 gfc_get_st_label (int labelno
)
2506 if (gfc_current_state () == COMP_DERIVED
)
2507 ns
= gfc_current_block ()->f2k_derived
;
2510 /* Find the namespace of the scoping unit:
2511 If we're in a BLOCK construct, jump to the parent namespace. */
2512 ns
= gfc_current_ns
;
2513 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2517 /* First see if the label is already in this namespace. */
2521 if (lp
->value
== labelno
)
2524 if (lp
->value
< labelno
)
2530 lp
= XCNEW (gfc_st_label
);
2532 lp
->value
= labelno
;
2533 lp
->defined
= ST_LABEL_UNKNOWN
;
2534 lp
->referenced
= ST_LABEL_UNKNOWN
;
2537 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2543 /* Called when a statement with a statement label is about to be
2544 accepted. We add the label to the list of the current namespace,
2545 making sure it hasn't been defined previously and referenced
2549 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2553 labelno
= lp
->value
;
2555 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2556 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2557 &lp
->where
, label_locus
);
2560 lp
->where
= *label_locus
;
2564 case ST_LABEL_FORMAT
:
2565 if (lp
->referenced
== ST_LABEL_TARGET
2566 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2567 gfc_error ("Label %d at %C already referenced as branch target",
2570 lp
->defined
= ST_LABEL_FORMAT
;
2574 case ST_LABEL_TARGET
:
2575 case ST_LABEL_DO_TARGET
:
2576 if (lp
->referenced
== ST_LABEL_FORMAT
)
2577 gfc_error ("Label %d at %C already referenced as a format label",
2582 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2583 && !gfc_notify_std (GFC_STD_F95_OBS
, "DO termination statement "
2584 "which is not END DO or CONTINUE with "
2585 "label %d at %C", labelno
))
2590 lp
->defined
= ST_LABEL_BAD_TARGET
;
2591 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2597 /* Reference a label. Given a label and its type, see if that
2598 reference is consistent with what is known about that label,
2599 updating the unknown state. Returns false if something goes
2603 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2605 gfc_sl_type label_type
;
2612 labelno
= lp
->value
;
2614 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2615 label_type
= lp
->defined
;
2618 label_type
= lp
->referenced
;
2619 lp
->where
= gfc_current_locus
;
2622 if (label_type
== ST_LABEL_FORMAT
2623 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2625 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2630 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2631 || label_type
== ST_LABEL_BAD_TARGET
)
2632 && type
== ST_LABEL_FORMAT
)
2634 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2639 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2640 && !gfc_notify_std (GFC_STD_F95_OBS
, "Shared DO termination label %d "
2644 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2645 lp
->referenced
= type
;
2653 /************** Symbol table management subroutines ****************/
2655 /* Basic details: Fortran 95 requires a potentially unlimited number
2656 of distinct namespaces when compiling a program unit. This case
2657 occurs during a compilation of internal subprograms because all of
2658 the internal subprograms must be read before we can start
2659 generating code for the host.
2661 Given the tricky nature of the Fortran grammar, we must be able to
2662 undo changes made to a symbol table if the current interpretation
2663 of a statement is found to be incorrect. Whenever a symbol is
2664 looked up, we make a copy of it and link to it. All of these
2665 symbols are kept in a vector so that we can commit or
2666 undo the changes at a later time.
2668 A symtree may point to a symbol node outside of its namespace. In
2669 this case, that symbol has been used as a host associated variable
2670 at some previous time. */
2672 /* Allocate a new namespace structure. Copies the implicit types from
2673 PARENT if PARENT_TYPES is set. */
2676 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2683 ns
= XCNEW (gfc_namespace
);
2684 ns
->sym_root
= NULL
;
2685 ns
->uop_root
= NULL
;
2686 ns
->tb_sym_root
= NULL
;
2687 ns
->finalizers
= NULL
;
2688 ns
->default_access
= ACCESS_UNKNOWN
;
2689 ns
->parent
= parent
;
2691 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2693 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2694 ns
->tb_op
[in
] = NULL
;
2697 /* Initialize default implicit types. */
2698 for (i
= 'a'; i
<= 'z'; i
++)
2700 ns
->set_flag
[i
- 'a'] = 0;
2701 ts
= &ns
->default_type
[i
- 'a'];
2703 if (parent_types
&& ns
->parent
!= NULL
)
2705 /* Copy parent settings. */
2706 *ts
= ns
->parent
->default_type
[i
- 'a'];
2710 if (flag_implicit_none
!= 0)
2716 if ('i' <= i
&& i
<= 'n')
2718 ts
->type
= BT_INTEGER
;
2719 ts
->kind
= gfc_default_integer_kind
;
2724 ts
->kind
= gfc_default_real_kind
;
2728 if (parent_types
&& ns
->parent
!= NULL
)
2729 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2737 /* Comparison function for symtree nodes. */
2740 compare_symtree (void *_st1
, void *_st2
)
2742 gfc_symtree
*st1
, *st2
;
2744 st1
= (gfc_symtree
*) _st1
;
2745 st2
= (gfc_symtree
*) _st2
;
2747 return strcmp (st1
->name
, st2
->name
);
2751 /* Allocate a new symtree node and associate it with the new symbol. */
2754 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2758 st
= XCNEW (gfc_symtree
);
2759 st
->name
= gfc_get_string ("%s", name
);
2761 gfc_insert_bbt (root
, st
, compare_symtree
);
2766 /* Delete a symbol from the tree. Does not free the symbol itself! */
2769 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2771 gfc_symtree st
, *st0
;
2773 st0
= gfc_find_symtree (*root
, name
);
2775 st
.name
= gfc_get_string ("%s", name
);
2776 gfc_delete_bbt (root
, &st
, compare_symtree
);
2782 /* Given a root symtree node and a name, try to find the symbol within
2783 the namespace. Returns NULL if the symbol is not found. */
2786 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2792 c
= strcmp (name
, st
->name
);
2796 st
= (c
< 0) ? st
->left
: st
->right
;
2803 /* Return a symtree node with a name that is guaranteed to be unique
2804 within the namespace and corresponds to an illegal fortran name. */
2807 gfc_get_unique_symtree (gfc_namespace
*ns
)
2809 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2810 static int serial
= 0;
2812 sprintf (name
, "@%d", serial
++);
2813 return gfc_new_symtree (&ns
->sym_root
, name
);
2817 /* Given a name find a user operator node, creating it if it doesn't
2818 exist. These are much simpler than symbols because they can't be
2819 ambiguous with one another. */
2822 gfc_get_uop (const char *name
)
2826 gfc_namespace
*ns
= gfc_current_ns
;
2830 st
= gfc_find_symtree (ns
->uop_root
, name
);
2834 st
= gfc_new_symtree (&ns
->uop_root
, name
);
2836 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2837 uop
->name
= gfc_get_string ("%s", name
);
2838 uop
->access
= ACCESS_UNKNOWN
;
2845 /* Given a name find the user operator node. Returns NULL if it does
2849 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2854 ns
= gfc_current_ns
;
2856 st
= gfc_find_symtree (ns
->uop_root
, name
);
2857 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2861 /* Update a symbol's common_block field, and take care of the associated
2862 memory management. */
2865 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
2867 if (sym
->common_block
== common_block
)
2870 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
2872 sym
->common_block
->refs
--;
2873 if (sym
->common_block
->refs
== 0)
2874 free (sym
->common_block
);
2876 sym
->common_block
= common_block
;
2880 /* Remove a gfc_symbol structure and everything it points to. */
2883 gfc_free_symbol (gfc_symbol
*sym
)
2889 gfc_free_array_spec (sym
->as
);
2891 free_components (sym
->components
);
2893 gfc_free_expr (sym
->value
);
2895 gfc_free_namelist (sym
->namelist
);
2897 if (sym
->ns
!= sym
->formal_ns
)
2898 gfc_free_namespace (sym
->formal_ns
);
2900 if (!sym
->attr
.generic_copy
)
2901 gfc_free_interface (sym
->generic
);
2903 gfc_free_formal_arglist (sym
->formal
);
2905 gfc_free_namespace (sym
->f2k_derived
);
2907 set_symbol_common_block (sym
, NULL
);
2913 /* Decrease the reference counter and free memory when we reach zero. */
2916 gfc_release_symbol (gfc_symbol
*sym
)
2921 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
2922 && (!sym
->attr
.entry
|| !sym
->module
))
2924 /* As formal_ns contains a reference to sym, delete formal_ns just
2925 before the deletion of sym. */
2926 gfc_namespace
*ns
= sym
->formal_ns
;
2927 sym
->formal_ns
= NULL
;
2928 gfc_free_namespace (ns
);
2935 gcc_assert (sym
->refs
== 0);
2936 gfc_free_symbol (sym
);
2940 /* Allocate and initialize a new symbol node. */
2943 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2947 p
= XCNEW (gfc_symbol
);
2949 gfc_clear_ts (&p
->ts
);
2950 gfc_clear_attr (&p
->attr
);
2953 p
->declared_at
= gfc_current_locus
;
2955 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2956 gfc_internal_error ("new_symbol(): Symbol name too long");
2958 p
->name
= gfc_get_string ("%s", name
);
2960 /* Make sure flags for symbol being C bound are clear initially. */
2961 p
->attr
.is_bind_c
= 0;
2962 p
->attr
.is_iso_c
= 0;
2964 /* Clear the ptrs we may need. */
2965 p
->common_block
= NULL
;
2966 p
->f2k_derived
= NULL
;
2968 p
->fn_result_spec
= 0;
2974 /* Generate an error if a symbol is ambiguous. */
2977 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2980 if (st
->n
.sym
->module
)
2981 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
2982 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2984 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
2985 "from current program unit", name
, st
->n
.sym
->name
);
2989 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2990 selector on the stack. If yes, replace it by the corresponding temporary. */
2993 select_type_insert_tmp (gfc_symtree
**st
)
2995 gfc_select_type_stack
*stack
= select_type_stack
;
2996 for (; stack
; stack
= stack
->prev
)
2997 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
3000 select_type_insert_tmp (st
);
3006 /* Look for a symtree in the current procedure -- that is, go up to
3007 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3010 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
3014 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
3018 if (!ns
->construct_entities
)
3027 /* Search for a symtree starting in the current namespace, resorting to
3028 any parent namespaces if requested by a nonzero parent_flag.
3029 Returns nonzero if the name is ambiguous. */
3032 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3033 gfc_symtree
**result
)
3038 ns
= gfc_current_ns
;
3042 st
= gfc_find_symtree (ns
->sym_root
, name
);
3045 select_type_insert_tmp (&st
);
3048 /* Ambiguous generic interfaces are permitted, as long
3049 as the specific interfaces are different. */
3050 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3052 ambiguous_symbol (name
, st
);
3062 /* Don't escape an interface block. */
3063 if (ns
&& !ns
->has_import_set
3064 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3076 /* Same, but returns the symbol instead. */
3079 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3080 gfc_symbol
**result
)
3085 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3090 *result
= st
->n
.sym
;
3096 /* Tells whether there is only one set of changes in the stack. */
3099 single_undo_checkpoint_p (void)
3101 if (latest_undo_chgset
== &default_undo_chgset_var
)
3103 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3108 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3113 /* Save symbol with the information necessary to back it out. */
3116 gfc_save_symbol_data (gfc_symbol
*sym
)
3121 if (!single_undo_checkpoint_p ())
3123 /* If there is more than one change set, look for the symbol in the
3124 current one. If it is found there, we can reuse it. */
3125 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3128 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3132 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3135 s
= XCNEW (gfc_symbol
);
3137 sym
->old_symbol
= s
;
3140 latest_undo_chgset
->syms
.safe_push (sym
);
3144 /* Given a name, find a symbol, or create it if it does not exist yet
3145 in the current namespace. If the symbol is found we make sure that
3148 The integer return code indicates
3150 1 The symbol name was ambiguous
3151 2 The name meant to be established was already host associated.
3153 So if the return value is nonzero, then an error was issued. */
3156 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3157 bool allow_subroutine
)
3162 /* This doesn't usually happen during resolution. */
3164 ns
= gfc_current_ns
;
3166 /* Try to find the symbol in ns. */
3167 st
= gfc_find_symtree (ns
->sym_root
, name
);
3169 if (st
== NULL
&& ns
->omp_udr_ns
)
3172 st
= gfc_find_symtree (ns
->sym_root
, name
);
3177 /* If not there, create a new symbol. */
3178 p
= gfc_new_symbol (name
, ns
);
3180 /* Add to the list of tentative symbols. */
3181 p
->old_symbol
= NULL
;
3184 latest_undo_chgset
->syms
.safe_push (p
);
3186 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3193 /* Make sure the existing symbol is OK. Ambiguous
3194 generic interfaces are permitted, as long as the
3195 specific interfaces are different. */
3196 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3198 ambiguous_symbol (name
, st
);
3203 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3204 && !(allow_subroutine
&& p
->attr
.subroutine
)
3205 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3206 && (ns
->has_import_set
|| p
->attr
.imported
)))
3208 /* Symbol is from another namespace. */
3209 gfc_error ("Symbol %qs at %C has already been host associated",
3216 /* Copy in case this symbol is changed. */
3217 gfc_save_symbol_data (p
);
3226 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3231 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3236 *result
= st
->n
.sym
;
3243 /* Subroutine that searches for a symbol, creating it if it doesn't
3244 exist, but tries to host-associate the symbol if possible. */
3247 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3252 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3256 gfc_save_symbol_data (st
->n
.sym
);
3261 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3271 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3276 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3281 i
= gfc_get_ha_sym_tree (name
, &st
);
3284 *result
= st
->n
.sym
;
3292 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3293 head->name as the common_root symtree's name might be mangled. */
3295 static gfc_symtree
*
3296 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3299 gfc_symtree
*result
;
3304 if (st
->n
.common
== head
)
3307 result
= find_common_symtree (st
->left
, head
);
3309 result
= find_common_symtree (st
->right
, head
);
3315 /* Clear the given storage, and make it the current change set for registering
3316 changed symbols. Its contents are freed after a call to
3317 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
3318 it is up to the caller to free the storage itself. It is usually a local
3319 variable, so there is nothing to do anyway. */
3322 gfc_new_undo_checkpoint (gfc_undo_change_set
&chg_syms
)
3324 chg_syms
.syms
= vNULL
;
3325 chg_syms
.tbps
= vNULL
;
3326 chg_syms
.previous
= latest_undo_chgset
;
3327 latest_undo_chgset
= &chg_syms
;
3331 /* Restore previous state of symbol. Just copy simple stuff. */
3334 restore_old_symbol (gfc_symbol
*p
)
3339 old
= p
->old_symbol
;
3341 p
->ts
.type
= old
->ts
.type
;
3342 p
->ts
.kind
= old
->ts
.kind
;
3344 p
->attr
= old
->attr
;
3346 if (p
->value
!= old
->value
)
3348 gcc_checking_assert (old
->value
== NULL
);
3349 gfc_free_expr (p
->value
);
3353 if (p
->as
!= old
->as
)
3356 gfc_free_array_spec (p
->as
);
3360 p
->generic
= old
->generic
;
3361 p
->component_access
= old
->component_access
;
3363 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3365 gfc_free_namelist (p
->namelist
);
3370 if (p
->namelist_tail
!= old
->namelist_tail
)
3372 gfc_free_namelist (old
->namelist_tail
->next
);
3373 old
->namelist_tail
->next
= NULL
;
3377 p
->namelist_tail
= old
->namelist_tail
;
3379 if (p
->formal
!= old
->formal
)
3381 gfc_free_formal_arglist (p
->formal
);
3382 p
->formal
= old
->formal
;
3385 set_symbol_common_block (p
, old
->common_block
);
3386 p
->common_head
= old
->common_head
;
3388 p
->old_symbol
= old
->old_symbol
;
3393 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3394 the structure itself. */
3397 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3404 /* Given a change set pointer, free its target's contents and update it with
3405 the address of the previous change set. Note that only the contents are
3406 freed, not the target itself (the contents' container). It is not a problem
3407 as the latter will be a local variable usually. */
3410 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3412 free_undo_change_set_data (*cs
);
3417 static void free_old_symbol (gfc_symbol
*sym
);
3420 /* Merges the current change set into the previous one. The changes themselves
3421 are left untouched; only one checkpoint is forgotten. */
3424 gfc_drop_last_undo_checkpoint (void)
3429 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3431 /* No need to loop in this case. */
3432 if (s
->old_symbol
== NULL
)
3435 /* Remove the duplicate symbols. */
3436 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3439 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3441 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3442 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3443 shall contain from now on the backup symbol for S as it was
3444 at the checkpoint before. */
3445 if (s
->old_symbol
->gfc_new
)
3447 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3448 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3449 free_old_symbol (s
);
3452 restore_old_symbol (s
->old_symbol
);
3457 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3458 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3460 pop_undo_change_set (latest_undo_chgset
);
3464 /* Undoes all the changes made to symbols since the previous checkpoint.
3465 This subroutine is made simpler due to the fact that attributes are
3466 never removed once added. */
3469 gfc_restore_last_undo_checkpoint (void)
3474 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3476 /* Symbol in a common block was new. Or was old and just put in common */
3478 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3480 /* If the symbol was added to any common block, it
3481 needs to be removed to stop the resolver looking
3482 for a (possibly) dead symbol. */
3483 if (p
->common_block
->head
== p
&& !p
->common_next
)
3485 gfc_symtree st
, *st0
;
3486 st0
= find_common_symtree (p
->ns
->common_root
,
3490 st
.name
= st0
->name
;
3491 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3496 if (p
->common_block
->head
== p
)
3497 p
->common_block
->head
= p
->common_next
;
3500 gfc_symbol
*cparent
, *csym
;
3502 cparent
= p
->common_block
->head
;
3503 csym
= cparent
->common_next
;
3508 csym
= csym
->common_next
;
3511 gcc_assert(cparent
->common_next
== p
);
3512 cparent
->common_next
= csym
->common_next
;
3514 p
->common_next
= NULL
;
3518 /* The derived type is saved in the symtree with the first
3519 letter capitalized; the all lower-case version to the
3520 derived type contains its associated generic function. */
3521 if (gfc_fl_struct (p
->attr
.flavor
))
3522 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3524 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3526 gfc_release_symbol (p
);
3529 restore_old_symbol (p
);
3532 latest_undo_chgset
->syms
.truncate (0);
3533 latest_undo_chgset
->tbps
.truncate (0);
3535 if (!single_undo_checkpoint_p ())
3536 pop_undo_change_set (latest_undo_chgset
);
3540 /* Makes sure that there is only one set of changes; in other words we haven't
3541 forgotten to pair a call to gfc_new_checkpoint with a call to either
3542 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3545 enforce_single_undo_checkpoint (void)
3547 gcc_checking_assert (single_undo_checkpoint_p ());
3551 /* Undoes all the changes made to symbols in the current statement. */
3554 gfc_undo_symbols (void)
3556 enforce_single_undo_checkpoint ();
3557 gfc_restore_last_undo_checkpoint ();
3561 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3562 components of old_symbol that might need deallocation are the "allocatables"
3563 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3564 namelist_tail. In case these differ between old_symbol and sym, it's just
3565 because sym->namelist has gotten a few more items. */
3568 free_old_symbol (gfc_symbol
*sym
)
3571 if (sym
->old_symbol
== NULL
)
3574 if (sym
->old_symbol
->as
!= sym
->as
)
3575 gfc_free_array_spec (sym
->old_symbol
->as
);
3577 if (sym
->old_symbol
->value
!= sym
->value
)
3578 gfc_free_expr (sym
->old_symbol
->value
);
3580 if (sym
->old_symbol
->formal
!= sym
->formal
)
3581 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3583 free (sym
->old_symbol
);
3584 sym
->old_symbol
= NULL
;
3588 /* Makes the changes made in the current statement permanent-- gets
3589 rid of undo information. */
3592 gfc_commit_symbols (void)
3595 gfc_typebound_proc
*tbp
;
3598 enforce_single_undo_checkpoint ();
3600 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3604 free_old_symbol (p
);
3606 latest_undo_chgset
->syms
.truncate (0);
3608 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3610 latest_undo_chgset
->tbps
.truncate (0);
3614 /* Makes the changes made in one symbol permanent -- gets rid of undo
3618 gfc_commit_symbol (gfc_symbol
*sym
)
3623 enforce_single_undo_checkpoint ();
3625 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3628 latest_undo_chgset
->syms
.unordered_remove (i
);
3635 free_old_symbol (sym
);
3639 /* Recursively free trees containing type-bound procedures. */
3642 free_tb_tree (gfc_symtree
*t
)
3647 free_tb_tree (t
->left
);
3648 free_tb_tree (t
->right
);
3650 /* TODO: Free type-bound procedure structs themselves; probably needs some
3651 sort of ref-counting mechanism. */
3657 /* Recursive function that deletes an entire tree and all the common
3658 head structures it points to. */
3661 free_common_tree (gfc_symtree
* common_tree
)
3663 if (common_tree
== NULL
)
3666 free_common_tree (common_tree
->left
);
3667 free_common_tree (common_tree
->right
);
3673 /* Recursive function that deletes an entire tree and all the common
3674 head structures it points to. */
3677 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3679 if (omp_udr_tree
== NULL
)
3682 free_omp_udr_tree (omp_udr_tree
->left
);
3683 free_omp_udr_tree (omp_udr_tree
->right
);
3685 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3686 free (omp_udr_tree
);
3690 /* Recursive function that deletes an entire tree and all the user
3691 operator nodes that it contains. */
3694 free_uop_tree (gfc_symtree
*uop_tree
)
3696 if (uop_tree
== NULL
)
3699 free_uop_tree (uop_tree
->left
);
3700 free_uop_tree (uop_tree
->right
);
3702 gfc_free_interface (uop_tree
->n
.uop
->op
);
3703 free (uop_tree
->n
.uop
);
3708 /* Recursive function that deletes an entire tree and all the symbols
3709 that it contains. */
3712 free_sym_tree (gfc_symtree
*sym_tree
)
3714 if (sym_tree
== NULL
)
3717 free_sym_tree (sym_tree
->left
);
3718 free_sym_tree (sym_tree
->right
);
3720 gfc_release_symbol (sym_tree
->n
.sym
);
3725 /* Free the derived type list. */
3728 gfc_free_dt_list (void)
3730 gfc_dt_list
*dt
, *n
;
3732 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3738 gfc_derived_types
= NULL
;
3742 /* Free the gfc_equiv_info's. */
3745 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3749 gfc_free_equiv_infos (s
->next
);
3754 /* Free the gfc_equiv_lists. */
3757 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3761 gfc_free_equiv_lists (l
->next
);
3762 gfc_free_equiv_infos (l
->equiv
);
3767 /* Free a finalizer procedure list. */
3770 gfc_free_finalizer (gfc_finalizer
* el
)
3774 gfc_release_symbol (el
->proc_sym
);
3780 gfc_free_finalizer_list (gfc_finalizer
* list
)
3784 gfc_finalizer
* current
= list
;
3786 gfc_free_finalizer (current
);
3791 /* Create a new gfc_charlen structure and add it to a namespace.
3792 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3795 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3799 cl
= gfc_get_charlen ();
3804 cl
->length
= gfc_copy_expr (old_cl
->length
);
3805 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3806 cl
->backend_decl
= old_cl
->backend_decl
;
3807 cl
->passed_length
= old_cl
->passed_length
;
3808 cl
->resolved
= old_cl
->resolved
;
3811 /* Put into namespace. */
3812 cl
->next
= ns
->cl_list
;
3819 /* Free the charlen list from cl to end (end is not freed).
3820 Free the whole list if end is NULL. */
3823 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3827 for (; cl
!= end
; cl
= cl2
)
3832 gfc_free_expr (cl
->length
);
3838 /* Free entry list structs. */
3841 free_entry_list (gfc_entry_list
*el
)
3843 gfc_entry_list
*next
;
3850 free_entry_list (next
);
3854 /* Free a namespace structure and everything below it. Interface
3855 lists associated with intrinsic operators are not freed. These are
3856 taken care of when a specific name is freed. */
3859 gfc_free_namespace (gfc_namespace
*ns
)
3861 gfc_namespace
*p
, *q
;
3870 gcc_assert (ns
->refs
== 0);
3872 gfc_free_statements (ns
->code
);
3874 free_sym_tree (ns
->sym_root
);
3875 free_uop_tree (ns
->uop_root
);
3876 free_common_tree (ns
->common_root
);
3877 free_omp_udr_tree (ns
->omp_udr_root
);
3878 free_tb_tree (ns
->tb_sym_root
);
3879 free_tb_tree (ns
->tb_uop_root
);
3880 gfc_free_finalizer_list (ns
->finalizers
);
3881 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
3882 gfc_free_charlen (ns
->cl_list
, NULL
);
3883 free_st_labels (ns
->st_labels
);
3885 free_entry_list (ns
->entries
);
3886 gfc_free_equiv (ns
->equiv
);
3887 gfc_free_equiv_lists (ns
->equiv_lists
);
3888 gfc_free_use_stmts (ns
->use_stmts
);
3890 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3891 gfc_free_interface (ns
->op
[i
]);
3893 gfc_free_data (ns
->data
);
3897 /* Recursively free any contained namespaces. */
3902 gfc_free_namespace (q
);
3908 gfc_symbol_init_2 (void)
3911 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3916 gfc_symbol_done_2 (void)
3918 gfc_free_namespace (gfc_current_ns
);
3919 gfc_current_ns
= NULL
;
3920 gfc_free_dt_list ();
3922 enforce_single_undo_checkpoint ();
3923 free_undo_change_set_data (*latest_undo_chgset
);
3927 /* Count how many nodes a symtree has. */
3930 count_st_nodes (const gfc_symtree
*st
)
3936 nodes
= count_st_nodes (st
->left
);
3938 nodes
+= count_st_nodes (st
->right
);
3944 /* Convert symtree tree into symtree vector. */
3947 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
3952 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
3953 st_vec
[node_cntr
++] = st
;
3954 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
3960 /* Traverse namespace. As the functions might modify the symtree, we store the
3961 symtree as a vector and operate on this vector. Note: We assume that
3962 sym_func or st_func never deletes nodes from the symtree - only adding is
3963 allowed. Additionally, newly added nodes are not traversed. */
3966 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
3967 void (*sym_func
) (gfc_symbol
*))
3969 gfc_symtree
**st_vec
;
3970 unsigned nodes
, i
, node_cntr
;
3972 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
3973 nodes
= count_st_nodes (st
);
3974 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
3976 fill_st_vector (st
, st_vec
, node_cntr
);
3981 for (i
= 0; i
< nodes
; i
++)
3982 st_vec
[i
]->n
.sym
->mark
= 0;
3983 for (i
= 0; i
< nodes
; i
++)
3984 if (!st_vec
[i
]->n
.sym
->mark
)
3986 (*sym_func
) (st_vec
[i
]->n
.sym
);
3987 st_vec
[i
]->n
.sym
->mark
= 1;
3991 for (i
= 0; i
< nodes
; i
++)
3992 (*st_func
) (st_vec
[i
]);
3996 /* Recursively traverse the symtree nodes. */
3999 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
4001 do_traverse_symtree (st
, st_func
, NULL
);
4005 /* Call a given function for all symbols in the namespace. We take
4006 care that each gfc_symbol node is called exactly once. */
4009 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
4011 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
4015 /* Return TRUE when name is the name of an intrinsic type. */
4018 gfc_is_intrinsic_typename (const char *name
)
4020 if (strcmp (name
, "integer") == 0
4021 || strcmp (name
, "real") == 0
4022 || strcmp (name
, "character") == 0
4023 || strcmp (name
, "logical") == 0
4024 || strcmp (name
, "complex") == 0
4025 || strcmp (name
, "doubleprecision") == 0
4026 || strcmp (name
, "doublecomplex") == 0)
4033 /* Return TRUE if the symbol is an automatic variable. */
4036 gfc_is_var_automatic (gfc_symbol
*sym
)
4038 /* Pointer and allocatable variables are never automatic. */
4039 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4041 /* Check for arrays with non-constant size. */
4042 if (sym
->attr
.dimension
&& sym
->as
4043 && !gfc_is_compile_time_shape (sym
->as
))
4045 /* Check for non-constant length character variables. */
4046 if (sym
->ts
.type
== BT_CHARACTER
4048 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4050 /* Variables with explicit AUTOMATIC attribute. */
4051 if (sym
->attr
.automatic
)
4057 /* Given a symbol, mark it as SAVEd if it is allowed. */
4060 save_symbol (gfc_symbol
*sym
)
4063 if (sym
->attr
.use_assoc
)
4066 if (sym
->attr
.in_common
4069 || sym
->attr
.flavor
!= FL_VARIABLE
)
4071 /* Automatic objects are not saved. */
4072 if (gfc_is_var_automatic (sym
))
4074 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4078 /* Mark those symbols which can be SAVEd as such. */
4081 gfc_save_all (gfc_namespace
*ns
)
4083 gfc_traverse_ns (ns
, save_symbol
);
4087 /* Make sure that no changes to symbols are pending. */
4090 gfc_enforce_clean_symbol_state(void)
4092 enforce_single_undo_checkpoint ();
4093 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4097 /************** Global symbol handling ************/
4100 /* Search a tree for the global symbol. */
4103 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4112 c
= strcmp (name
, symbol
->name
);
4116 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4123 /* Compare two global symbols. Used for managing the BB tree. */
4126 gsym_compare (void *_s1
, void *_s2
)
4128 gfc_gsymbol
*s1
, *s2
;
4130 s1
= (gfc_gsymbol
*) _s1
;
4131 s2
= (gfc_gsymbol
*) _s2
;
4132 return strcmp (s1
->name
, s2
->name
);
4136 /* Get a global symbol, creating it if it doesn't exist. */
4139 gfc_get_gsymbol (const char *name
)
4143 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4147 s
= XCNEW (gfc_gsymbol
);
4148 s
->type
= GSYM_UNKNOWN
;
4149 s
->name
= gfc_get_string ("%s", name
);
4151 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4158 get_iso_c_binding_dt (int sym_id
)
4160 gfc_dt_list
*dt_list
;
4162 dt_list
= gfc_derived_types
;
4164 /* Loop through the derived types in the name list, searching for
4165 the desired symbol from iso_c_binding. Search the parent namespaces
4166 if necessary and requested to (parent_flag). */
4167 while (dt_list
!= NULL
)
4169 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
4170 && dt_list
->derived
->intmod_sym_id
== sym_id
)
4171 return dt_list
->derived
;
4173 dt_list
= dt_list
->next
;
4180 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4181 with C. This is necessary for any derived type that is BIND(C) and for
4182 derived types that are parameters to functions that are BIND(C). All
4183 fields of the derived type are required to be interoperable, and are tested
4184 for such. If an error occurs, the errors are reported here, allowing for
4185 multiple errors to be handled for a single derived type. */
4188 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4190 gfc_component
*curr_comp
= NULL
;
4191 bool is_c_interop
= false;
4194 if (derived_sym
== NULL
)
4195 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4196 "unexpectedly NULL");
4198 /* If we've already looked at this derived symbol, do not look at it again
4199 so we don't repeat warnings/errors. */
4200 if (derived_sym
->ts
.is_c_interop
)
4203 /* The derived type must have the BIND attribute to be interoperable
4204 J3/04-007, Section 15.2.3. */
4205 if (derived_sym
->attr
.is_bind_c
!= 1)
4207 derived_sym
->ts
.is_c_interop
= 0;
4208 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4209 "attribute to be C interoperable", derived_sym
->name
,
4210 &(derived_sym
->declared_at
));
4214 curr_comp
= derived_sym
->components
;
4216 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4217 empty struct. Section 15.2 in Fortran 2003 states: "The following
4218 subclauses define the conditions under which a Fortran entity is
4219 interoperable. If a Fortran entity is interoperable, an equivalent
4220 entity may be defined by means of C and the Fortran entity is said
4221 to be interoperable with the C entity. There does not have to be such
4222 an interoperating C entity."
4224 if (curr_comp
== NULL
)
4226 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4227 "and may be inaccessible by the C companion processor",
4228 derived_sym
->name
, &(derived_sym
->declared_at
));
4229 derived_sym
->ts
.is_c_interop
= 1;
4230 derived_sym
->attr
.is_bind_c
= 1;
4235 /* Initialize the derived type as being C interoperable.
4236 If we find an error in the components, this will be set false. */
4237 derived_sym
->ts
.is_c_interop
= 1;
4239 /* Loop through the list of components to verify that the kind of
4240 each is a C interoperable type. */
4243 /* The components cannot be pointers (fortran sense).
4244 J3/04-007, Section 15.2.3, C1505. */
4245 if (curr_comp
->attr
.pointer
!= 0)
4247 gfc_error ("Component %qs at %L cannot have the "
4248 "POINTER attribute because it is a member "
4249 "of the BIND(C) derived type %qs at %L",
4250 curr_comp
->name
, &(curr_comp
->loc
),
4251 derived_sym
->name
, &(derived_sym
->declared_at
));
4255 if (curr_comp
->attr
.proc_pointer
!= 0)
4257 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4258 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4259 &curr_comp
->loc
, derived_sym
->name
,
4260 &derived_sym
->declared_at
);
4264 /* The components cannot be allocatable.
4265 J3/04-007, Section 15.2.3, C1505. */
4266 if (curr_comp
->attr
.allocatable
!= 0)
4268 gfc_error ("Component %qs at %L cannot have the "
4269 "ALLOCATABLE attribute because it is a member "
4270 "of the BIND(C) derived type %qs at %L",
4271 curr_comp
->name
, &(curr_comp
->loc
),
4272 derived_sym
->name
, &(derived_sym
->declared_at
));
4276 /* BIND(C) derived types must have interoperable components. */
4277 if (curr_comp
->ts
.type
== BT_DERIVED
4278 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4279 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4281 /* This should be allowed; the draft says a derived-type can not
4282 have type parameters if it is has the BIND attribute. Type
4283 parameters seem to be for making parameterized derived types.
4284 There's no need to verify the type if it is c_ptr/c_funptr. */
4285 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4289 /* Grab the typespec for the given component and test the kind. */
4290 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4294 /* Report warning and continue since not fatal. The
4295 draft does specify a constraint that requires all fields
4296 to interoperate, but if the user says real(4), etc., it
4297 may interoperate with *something* in C, but the compiler
4298 most likely won't know exactly what. Further, it may not
4299 interoperate with the same data type(s) in C if the user
4300 recompiles with different flags (e.g., -m32 and -m64 on
4301 x86_64 and using integer(4) to claim interop with a
4303 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4304 /* If the derived type is bind(c), all fields must be
4306 gfc_warning (OPT_Wc_binding_type
,
4307 "Component %qs in derived type %qs at %L "
4308 "may not be C interoperable, even though "
4309 "derived type %qs is BIND(C)",
4310 curr_comp
->name
, derived_sym
->name
,
4311 &(curr_comp
->loc
), derived_sym
->name
);
4312 else if (warn_c_binding_type
)
4313 /* If derived type is param to bind(c) routine, or to one
4314 of the iso_c_binding procs, it must be interoperable, so
4315 all fields must interop too. */
4316 gfc_warning (OPT_Wc_binding_type
,
4317 "Component %qs in derived type %qs at %L "
4318 "may not be C interoperable",
4319 curr_comp
->name
, derived_sym
->name
,
4324 curr_comp
= curr_comp
->next
;
4325 } while (curr_comp
!= NULL
);
4328 /* Make sure we don't have conflicts with the attributes. */
4329 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
4331 gfc_error ("Derived type %qs at %L cannot be declared with both "
4332 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
4333 &(derived_sym
->declared_at
));
4337 if (derived_sym
->attr
.sequence
!= 0)
4339 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4340 "attribute because it is BIND(C)", derived_sym
->name
,
4341 &(derived_sym
->declared_at
));
4345 /* Mark the derived type as not being C interoperable if we found an
4346 error. If there were only warnings, proceed with the assumption
4347 it's interoperable. */
4349 derived_sym
->ts
.is_c_interop
= 0;
4355 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4358 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4362 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4363 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4365 tmp_sym
->attr
.is_c_interop
= 1;
4366 tmp_sym
->attr
.is_bind_c
= 1;
4367 tmp_sym
->ts
.is_c_interop
= 1;
4368 tmp_sym
->ts
.is_iso_c
= 1;
4369 tmp_sym
->ts
.type
= BT_DERIVED
;
4370 tmp_sym
->ts
.f90_type
= BT_VOID
;
4371 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4372 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4374 /* Set the c_address field of c_null_ptr and c_null_funptr to
4375 the value of NULL. */
4376 tmp_sym
->value
= gfc_get_expr ();
4377 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4378 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4379 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4380 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4381 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4382 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4383 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4384 c
->expr
->ts
.is_iso_c
= 1;
4390 /* Add a formal argument, gfc_formal_arglist, to the
4391 end of the given list of arguments. Set the reference to the
4392 provided symbol, param_sym, in the argument. */
4395 add_formal_arg (gfc_formal_arglist
**head
,
4396 gfc_formal_arglist
**tail
,
4397 gfc_formal_arglist
*formal_arg
,
4398 gfc_symbol
*param_sym
)
4400 /* Put in list, either as first arg or at the tail (curr arg). */
4402 *head
= *tail
= formal_arg
;
4405 (*tail
)->next
= formal_arg
;
4406 (*tail
) = formal_arg
;
4409 (*tail
)->sym
= param_sym
;
4410 (*tail
)->next
= NULL
;
4416 /* Add a procedure interface to the given symbol (i.e., store a
4417 reference to the list of formal arguments). */
4420 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4423 sym
->formal
= formal
;
4424 sym
->attr
.if_source
= source
;
4428 /* Copy the formal args from an existing symbol, src, into a new
4429 symbol, dest. New formal args are created, and the description of
4430 each arg is set according to the existing ones. This function is
4431 used when creating procedure declaration variables from a procedure
4432 declaration statement (see match_proc_decl()) to create the formal
4433 args based on the args of a given named interface.
4435 When an actual argument list is provided, skip the absent arguments.
4436 To be used together with gfc_se->ignore_optional. */
4439 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4440 gfc_actual_arglist
*actual
)
4442 gfc_formal_arglist
*head
= NULL
;
4443 gfc_formal_arglist
*tail
= NULL
;
4444 gfc_formal_arglist
*formal_arg
= NULL
;
4445 gfc_intrinsic_arg
*curr_arg
= NULL
;
4446 gfc_formal_arglist
*formal_prev
= NULL
;
4447 gfc_actual_arglist
*act_arg
= actual
;
4448 /* Save current namespace so we can change it for formal args. */
4449 gfc_namespace
*parent_ns
= gfc_current_ns
;
4451 /* Create a new namespace, which will be the formal ns (namespace
4452 of the formal args). */
4453 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4454 gfc_current_ns
->proc_name
= dest
;
4456 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4458 /* Skip absent arguments. */
4461 gcc_assert (act_arg
!= NULL
);
4462 if (act_arg
->expr
== NULL
)
4464 act_arg
= act_arg
->next
;
4467 act_arg
= act_arg
->next
;
4469 formal_arg
= gfc_get_formal_arglist ();
4470 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4472 /* May need to copy more info for the symbol. */
4473 formal_arg
->sym
->ts
= curr_arg
->ts
;
4474 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4475 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4476 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4477 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4478 formal_arg
->sym
->attr
.dummy
= 1;
4480 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4481 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4483 /* If this isn't the first arg, set up the next ptr. For the
4484 last arg built, the formal_arg->next will never get set to
4485 anything other than NULL. */
4486 if (formal_prev
!= NULL
)
4487 formal_prev
->next
= formal_arg
;
4489 formal_arg
->next
= NULL
;
4491 formal_prev
= formal_arg
;
4493 /* Add arg to list of formal args. */
4494 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4496 /* Validate changes. */
4497 gfc_commit_symbol (formal_arg
->sym
);
4500 /* Add the interface to the symbol. */
4501 add_proc_interface (dest
, IFSRC_DECL
, head
);
4503 /* Store the formal namespace information. */
4504 if (dest
->formal
!= NULL
)
4505 /* The current ns should be that for the dest proc. */
4506 dest
->formal_ns
= gfc_current_ns
;
4507 /* Restore the current namespace to what it was on entry. */
4508 gfc_current_ns
= parent_ns
;
4513 std_for_isocbinding_symbol (int id
)
4517 #define NAMED_INTCST(a,b,c,d) \
4520 #include "iso-c-binding.def"
4523 #define NAMED_FUNCTION(a,b,c,d) \
4526 #define NAMED_SUBROUTINE(a,b,c,d) \
4529 #include "iso-c-binding.def"
4530 #undef NAMED_FUNCTION
4531 #undef NAMED_SUBROUTINE
4534 return GFC_STD_F2003
;
4538 /* Generate the given set of C interoperable kind objects, or all
4539 interoperable kinds. This function will only be given kind objects
4540 for valid iso_c_binding defined types because this is verified when
4541 the 'use' statement is parsed. If the user gives an 'only' clause,
4542 the specific kinds are looked up; if they don't exist, an error is
4543 reported. If the user does not give an 'only' clause, all
4544 iso_c_binding symbols are generated. If a list of specific kinds
4545 is given, it must have a NULL in the first empty spot to mark the
4546 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4547 point to the symtree for c_(fun)ptr. */
4550 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4551 const char *local_name
, gfc_symtree
*dt_symtree
,
4554 const char *const name
= (local_name
&& local_name
[0])
4555 ? local_name
: c_interop_kinds_table
[s
].name
;
4556 gfc_symtree
*tmp_symtree
;
4557 gfc_symbol
*tmp_sym
= NULL
;
4560 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4563 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4565 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4566 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4567 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4570 /* Already exists in this scope so don't re-add it. */
4571 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4572 && (!tmp_sym
->attr
.generic
4573 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4574 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4576 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4577 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4579 gfc_dt_list
*dt_list
;
4580 dt_list
= gfc_get_dt_list ();
4581 dt_list
->derived
= tmp_sym
;
4582 dt_list
->next
= gfc_derived_types
;
4583 gfc_derived_types
= dt_list
;
4589 /* Create the sym tree in the current ns. */
4592 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4593 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4595 /* Add to the list of tentative symbols. */
4596 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4597 tmp_sym
->old_symbol
= NULL
;
4599 tmp_sym
->gfc_new
= 1;
4601 tmp_symtree
->n
.sym
= tmp_sym
;
4606 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4607 gcc_assert (tmp_symtree
);
4608 tmp_sym
= tmp_symtree
->n
.sym
;
4611 /* Say what module this symbol belongs to. */
4612 tmp_sym
->module
= gfc_get_string ("%s", mod_name
);
4613 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4614 tmp_sym
->intmod_sym_id
= s
;
4615 tmp_sym
->attr
.is_iso_c
= 1;
4616 tmp_sym
->attr
.use_assoc
= 1;
4618 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4619 || s
== ISOCBINDING_NULL_PTR
);
4624 #define NAMED_INTCST(a,b,c,d) case a :
4625 #define NAMED_REALCST(a,b,c,d) case a :
4626 #define NAMED_CMPXCST(a,b,c,d) case a :
4627 #define NAMED_LOGCST(a,b,c) case a :
4628 #define NAMED_CHARKNDCST(a,b,c) case a :
4629 #include "iso-c-binding.def"
4631 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4632 c_interop_kinds_table
[s
].value
);
4634 /* Initialize an integer constant expression node. */
4635 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4636 tmp_sym
->ts
.type
= BT_INTEGER
;
4637 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4639 /* Mark this type as a C interoperable one. */
4640 tmp_sym
->ts
.is_c_interop
= 1;
4641 tmp_sym
->ts
.is_iso_c
= 1;
4642 tmp_sym
->value
->ts
.is_c_interop
= 1;
4643 tmp_sym
->value
->ts
.is_iso_c
= 1;
4644 tmp_sym
->attr
.is_c_interop
= 1;
4646 /* Tell what f90 type this c interop kind is valid. */
4647 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4652 #define NAMED_CHARCST(a,b,c) case a :
4653 #include "iso-c-binding.def"
4655 /* Initialize an integer constant expression node for the
4656 length of the character. */
4657 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4658 &gfc_current_locus
, NULL
, 1);
4659 tmp_sym
->value
->ts
.is_c_interop
= 1;
4660 tmp_sym
->value
->ts
.is_iso_c
= 1;
4661 tmp_sym
->value
->value
.character
.length
= 1;
4662 tmp_sym
->value
->value
.character
.string
[0]
4663 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4664 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4665 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4668 /* May not need this in both attr and ts, but do need in
4669 attr for writing module file. */
4670 tmp_sym
->attr
.is_c_interop
= 1;
4672 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4673 tmp_sym
->ts
.type
= BT_CHARACTER
;
4675 /* Need to set it to the C_CHAR kind. */
4676 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4678 /* Mark this type as a C interoperable one. */
4679 tmp_sym
->ts
.is_c_interop
= 1;
4680 tmp_sym
->ts
.is_iso_c
= 1;
4682 /* Tell what f90 type this c interop kind is valid. */
4683 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4687 case ISOCBINDING_PTR
:
4688 case ISOCBINDING_FUNPTR
:
4691 gfc_dt_list
**dt_list_ptr
= NULL
;
4692 gfc_component
*tmp_comp
= NULL
;
4694 /* Generate real derived type. */
4699 const char *hidden_name
;
4700 gfc_interface
*intr
, *head
;
4702 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4703 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4705 gcc_assert (tmp_symtree
== NULL
);
4706 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4707 dt_sym
= tmp_symtree
->n
.sym
;
4708 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4709 ? "c_ptr" : "c_funptr");
4711 /* Generate an artificial generic function. */
4712 head
= tmp_sym
->generic
;
4713 intr
= gfc_get_interface ();
4715 intr
->where
= gfc_current_locus
;
4717 tmp_sym
->generic
= intr
;
4719 if (!tmp_sym
->attr
.generic
4720 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4723 if (!tmp_sym
->attr
.function
4724 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4728 /* Say what module this symbol belongs to. */
4729 dt_sym
->module
= gfc_get_string ("%s", mod_name
);
4730 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4731 dt_sym
->intmod_sym_id
= s
;
4732 dt_sym
->attr
.use_assoc
= 1;
4734 /* Initialize an integer constant expression node. */
4735 dt_sym
->attr
.flavor
= FL_DERIVED
;
4736 dt_sym
->ts
.is_c_interop
= 1;
4737 dt_sym
->attr
.is_c_interop
= 1;
4738 dt_sym
->attr
.private_comp
= 1;
4739 dt_sym
->component_access
= ACCESS_PRIVATE
;
4740 dt_sym
->ts
.is_iso_c
= 1;
4741 dt_sym
->ts
.type
= BT_DERIVED
;
4742 dt_sym
->ts
.f90_type
= BT_VOID
;
4744 /* A derived type must have the bind attribute to be
4745 interoperable (J3/04-007, Section 15.2.3), even though
4746 the binding label is not used. */
4747 dt_sym
->attr
.is_bind_c
= 1;
4749 dt_sym
->attr
.referenced
= 1;
4750 dt_sym
->ts
.u
.derived
= dt_sym
;
4752 /* Add the symbol created for the derived type to the current ns. */
4753 dt_list_ptr
= &(gfc_derived_types
);
4754 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4755 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4757 /* There is already at least one derived type in the list, so append
4758 the one we're currently building for c_ptr or c_funptr. */
4759 if (*dt_list_ptr
!= NULL
)
4760 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4761 (*dt_list_ptr
) = gfc_get_dt_list ();
4762 (*dt_list_ptr
)->derived
= dt_sym
;
4763 (*dt_list_ptr
)->next
= NULL
;
4765 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4766 if (tmp_comp
== NULL
)
4769 tmp_comp
->ts
.type
= BT_INTEGER
;
4771 /* Set this because the module will need to read/write this field. */
4772 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4774 /* The kinds for c_ptr and c_funptr are the same. */
4775 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4776 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4777 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4779 /* Mark the component as C interoperable. */
4780 tmp_comp
->ts
.is_c_interop
= 1;
4785 case ISOCBINDING_NULL_PTR
:
4786 case ISOCBINDING_NULL_FUNPTR
:
4787 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4793 gfc_commit_symbol (tmp_sym
);
4798 /* Check that a symbol is already typed. If strict is not set, an untyped
4799 symbol is acceptable for non-standard-conforming mode. */
4802 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4803 bool strict
, locus where
)
4807 if (gfc_matching_prefix
)
4810 /* Check for the type and try to give it an implicit one. */
4811 if (sym
->ts
.type
== BT_UNKNOWN
4812 && !gfc_set_default_type (sym
, 0, ns
))
4816 gfc_error ("Symbol %qs is used before it is typed at %L",
4821 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
4822 " it is typed at %L", sym
->name
, &where
))
4826 /* Everything is ok. */
4831 /* Construct a typebound-procedure structure. Those are stored in a tentative
4832 list and marked `error' until symbols are committed. */
4835 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4837 gfc_typebound_proc
*result
;
4839 result
= XCNEW (gfc_typebound_proc
);
4844 latest_undo_chgset
->tbps
.safe_push (result
);
4850 /* Get the super-type of a given derived type. */
4853 gfc_get_derived_super_type (gfc_symbol
* derived
)
4855 gcc_assert (derived
);
4857 if (derived
->attr
.generic
)
4858 derived
= gfc_find_dt_in_generic (derived
);
4860 if (!derived
->attr
.extension
)
4863 gcc_assert (derived
->components
);
4864 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4865 gcc_assert (derived
->components
->ts
.u
.derived
);
4867 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4868 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4870 return derived
->components
->ts
.u
.derived
;
4874 /* Get the ultimate super-type of a given derived type. */
4877 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4879 if (!derived
->attr
.extension
)
4882 derived
= gfc_get_derived_super_type (derived
);
4884 if (derived
->attr
.extension
)
4885 return gfc_get_ultimate_derived_super_type (derived
);
4891 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4894 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4896 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4897 t2
= gfc_get_derived_super_type (t2
);
4898 return gfc_compare_derived_types (t1
, t2
);
4902 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4903 If ts1 is nonpolymorphic, ts2 must be the same type.
4904 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4907 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4909 bool is_class1
= (ts1
->type
== BT_CLASS
);
4910 bool is_class2
= (ts2
->type
== BT_CLASS
);
4911 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4912 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4913 bool is_union1
= (ts1
->type
== BT_UNION
);
4914 bool is_union2
= (ts2
->type
== BT_UNION
);
4917 && ts1
->u
.derived
->components
4918 && ((ts1
->u
.derived
->attr
.is_class
4919 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
4920 .unlimited_polymorphic
)
4921 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
4924 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
4925 && !is_union1
&& !is_union2
)
4926 return (ts1
->type
== ts2
->type
);
4928 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
4929 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4931 if (is_derived1
&& is_class2
)
4932 return gfc_compare_derived_types (ts1
->u
.derived
,
4933 ts2
->u
.derived
->attr
.is_class
?
4934 ts2
->u
.derived
->components
->ts
.u
.derived
4936 if (is_class1
&& is_derived2
)
4937 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
4938 ts1
->u
.derived
->components
->ts
.u
.derived
4941 else if (is_class1
&& is_class2
)
4942 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
4943 ts1
->u
.derived
->components
->ts
.u
.derived
4945 ts2
->u
.derived
->attr
.is_class
?
4946 ts2
->u
.derived
->components
->ts
.u
.derived
4953 /* Find the parent-namespace of the current function. If we're inside
4954 BLOCK constructs, it may not be the current one. */
4957 gfc_find_proc_namespace (gfc_namespace
* ns
)
4959 while (ns
->construct_entities
)
4969 /* Check if an associate-variable should be translated as an `implicit' pointer
4970 internally (if it is associated to a variable and not an array with
4974 gfc_is_associate_pointer (gfc_symbol
* sym
)
4979 if (sym
->ts
.type
== BT_CLASS
)
4982 if (!sym
->assoc
->variable
)
4985 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
4993 gfc_find_dt_in_generic (gfc_symbol
*sym
)
4995 gfc_interface
*intr
= NULL
;
4997 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
5000 if (sym
->attr
.generic
)
5001 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
5002 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
5004 return intr
? intr
->sym
: NULL
;
5008 /* Get the dummy arguments from a procedure symbol. If it has been declared
5009 via a PROCEDURE statement with a named interface, ts.interface will be set
5010 and the arguments need to be taken from there. */
5012 gfc_formal_arglist
*
5013 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
5015 gfc_formal_arglist
*dummies
;
5017 dummies
= sym
->formal
;
5018 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
5019 dummies
= sym
->ts
.interface
->formal
;