1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2016 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 *oacc_declare_copyin
= "OACC DECLARE COPYIN";
389 static const char *oacc_declare_create
= "OACC DECLARE CREATE";
390 static const char *oacc_declare_deviceptr
= "OACC DECLARE DEVICEPTR";
391 static const char *oacc_declare_device_resident
=
392 "OACC DECLARE DEVICE_RESIDENT";
398 where
= &gfc_current_locus
;
400 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
404 standard
= GFC_STD_F2003
;
408 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
411 a2
= attr
->allocatable
? allocatable
: pointer
;
412 standard
= GFC_STD_F2003
;
416 /* Check for attributes not allowed in a BLOCK DATA. */
417 if (gfc_current_state () == COMP_BLOCK_DATA
)
421 if (attr
->in_namelist
)
423 if (attr
->allocatable
)
429 if (attr
->access
== ACCESS_PRIVATE
)
431 if (attr
->access
== ACCESS_PUBLIC
)
433 if (attr
->intent
!= INTENT_UNKNOWN
)
439 ("%s attribute not allowed in BLOCK DATA program unit at %L",
445 if (attr
->save
== SAVE_EXPLICIT
)
448 conf (in_common
, save
);
450 conf (automatic
, save
);
452 switch (attr
->flavor
)
460 a1
= gfc_code2string (flavors
, attr
->flavor
);
464 gfc_error ("Namelist group name at %L cannot have the "
465 "SAVE attribute", where
);
468 /* Conflicts between SAVE and PROCEDURE will be checked at
469 resolution stage, see "resolve_fl_procedure". */
476 if (attr
->dummy
&& ((attr
->function
|| attr
->subroutine
) &&
477 gfc_current_state () == COMP_CONTAINS
))
478 gfc_error_now ("internal procedure %qs at %L conflicts with "
479 "DUMMY argument", name
, where
);
482 conf (dummy
, intrinsic
);
483 conf (dummy
, threadprivate
);
484 conf (dummy
, omp_declare_target
);
485 conf (pointer
, target
);
486 conf (pointer
, intrinsic
);
487 conf (pointer
, elemental
);
488 conf (pointer
, codimension
);
489 conf (allocatable
, elemental
);
491 conf (in_common
, automatic
);
492 conf (in_equivalence
, automatic
);
493 conf (result
, automatic
);
494 conf (use_assoc
, automatic
);
495 conf (dummy
, automatic
);
497 conf (target
, external
);
498 conf (target
, intrinsic
);
500 if (!attr
->if_source
)
501 conf (external
, dimension
); /* See Fortran 95's R504. */
503 conf (external
, intrinsic
);
504 conf (entry
, intrinsic
);
506 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
507 conf (external
, subroutine
);
509 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
510 "Procedure pointer at %C"))
513 conf (allocatable
, pointer
);
514 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
515 conf_std (allocatable
, function
, GFC_STD_F2003
);
516 conf_std (allocatable
, result
, GFC_STD_F2003
);
517 conf (elemental
, recursive
);
519 conf (in_common
, dummy
);
520 conf (in_common
, allocatable
);
521 conf (in_common
, codimension
);
522 conf (in_common
, result
);
524 conf (in_equivalence
, use_assoc
);
525 conf (in_equivalence
, codimension
);
526 conf (in_equivalence
, dummy
);
527 conf (in_equivalence
, target
);
528 conf (in_equivalence
, pointer
);
529 conf (in_equivalence
, function
);
530 conf (in_equivalence
, result
);
531 conf (in_equivalence
, entry
);
532 conf (in_equivalence
, allocatable
);
533 conf (in_equivalence
, threadprivate
);
534 conf (in_equivalence
, omp_declare_target
);
535 conf (in_equivalence
, oacc_declare_create
);
536 conf (in_equivalence
, oacc_declare_copyin
);
537 conf (in_equivalence
, oacc_declare_deviceptr
);
538 conf (in_equivalence
, oacc_declare_device_resident
);
540 conf (dummy
, result
);
541 conf (entry
, result
);
542 conf (generic
, result
);
544 conf (function
, subroutine
);
546 if (!function
&& !subroutine
)
547 conf (is_bind_c
, dummy
);
549 conf (is_bind_c
, cray_pointer
);
550 conf (is_bind_c
, cray_pointee
);
551 conf (is_bind_c
, codimension
);
552 conf (is_bind_c
, allocatable
);
553 conf (is_bind_c
, elemental
);
555 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
556 Parameter conflict caught below. Also, value cannot be specified
557 for a dummy procedure. */
559 /* Cray pointer/pointee conflicts. */
560 conf (cray_pointer
, cray_pointee
);
561 conf (cray_pointer
, dimension
);
562 conf (cray_pointer
, codimension
);
563 conf (cray_pointer
, contiguous
);
564 conf (cray_pointer
, pointer
);
565 conf (cray_pointer
, target
);
566 conf (cray_pointer
, allocatable
);
567 conf (cray_pointer
, external
);
568 conf (cray_pointer
, intrinsic
);
569 conf (cray_pointer
, in_namelist
);
570 conf (cray_pointer
, function
);
571 conf (cray_pointer
, subroutine
);
572 conf (cray_pointer
, entry
);
574 conf (cray_pointee
, allocatable
);
575 conf (cray_pointee
, contiguous
);
576 conf (cray_pointee
, codimension
);
577 conf (cray_pointee
, intent
);
578 conf (cray_pointee
, optional
);
579 conf (cray_pointee
, dummy
);
580 conf (cray_pointee
, target
);
581 conf (cray_pointee
, intrinsic
);
582 conf (cray_pointee
, pointer
);
583 conf (cray_pointee
, entry
);
584 conf (cray_pointee
, in_common
);
585 conf (cray_pointee
, in_equivalence
);
586 conf (cray_pointee
, threadprivate
);
587 conf (cray_pointee
, omp_declare_target
);
588 conf (cray_pointee
, oacc_declare_create
);
589 conf (cray_pointee
, oacc_declare_copyin
);
590 conf (cray_pointee
, oacc_declare_deviceptr
);
591 conf (cray_pointee
, oacc_declare_device_resident
);
594 conf (data
, function
);
596 conf (data
, allocatable
);
598 conf (value
, pointer
)
599 conf (value
, allocatable
)
600 conf (value
, subroutine
)
601 conf (value
, function
)
602 conf (value
, volatile_
)
603 conf (value
, dimension
)
604 conf (value
, codimension
)
605 conf (value
, external
)
607 conf (codimension
, result
)
610 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
613 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
617 conf (is_protected
, intrinsic
)
618 conf (is_protected
, in_common
)
620 conf (asynchronous
, intrinsic
)
621 conf (asynchronous
, external
)
623 conf (volatile_
, intrinsic
)
624 conf (volatile_
, external
)
626 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
633 conf (procedure
, allocatable
)
634 conf (procedure
, dimension
)
635 conf (procedure
, codimension
)
636 conf (procedure
, intrinsic
)
637 conf (procedure
, target
)
638 conf (procedure
, value
)
639 conf (procedure
, volatile_
)
640 conf (procedure
, asynchronous
)
641 conf (procedure
, entry
)
643 conf (proc_pointer
, abstract
)
645 conf (entry
, omp_declare_target
)
646 conf (entry
, oacc_declare_create
)
647 conf (entry
, oacc_declare_copyin
)
648 conf (entry
, oacc_declare_deviceptr
)
649 conf (entry
, oacc_declare_device_resident
)
651 a1
= gfc_code2string (flavors
, attr
->flavor
);
653 if (attr
->in_namelist
654 && attr
->flavor
!= FL_VARIABLE
655 && attr
->flavor
!= FL_PROCEDURE
656 && attr
->flavor
!= FL_UNKNOWN
)
662 switch (attr
->flavor
)
672 conf2 (asynchronous
);
675 conf2 (is_protected
);
685 conf2 (threadprivate
);
686 conf2 (omp_declare_target
);
687 conf2 (oacc_declare_create
);
688 conf2 (oacc_declare_copyin
);
689 conf2 (oacc_declare_deviceptr
);
690 conf2 (oacc_declare_device_resident
);
692 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
694 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
695 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
702 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
716 /* Conflicts with INTENT, SAVE and RESULT will be checked
717 at resolution stage, see "resolve_fl_procedure". */
719 if (attr
->subroutine
)
725 conf2 (asynchronous
);
730 if (!attr
->proc_pointer
)
731 conf2 (threadprivate
);
734 if (!attr
->proc_pointer
)
739 case PROC_ST_FUNCTION
:
750 conf2 (threadprivate
);
770 conf2 (threadprivate
);
772 conf2 (omp_declare_target
);
773 conf2 (oacc_declare_create
);
774 conf2 (oacc_declare_copyin
);
775 conf2 (oacc_declare_deviceptr
);
776 conf2 (oacc_declare_device_resident
);
778 if (attr
->intent
!= INTENT_UNKNOWN
)
795 conf2 (is_protected
);
801 conf2 (asynchronous
);
802 conf2 (threadprivate
);
818 gfc_error ("%s attribute conflicts with %s attribute at %L",
821 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
822 a1
, a2
, name
, where
);
829 return gfc_notify_std (standard
, "%s attribute "
830 "with %s attribute at %L", a1
, a2
,
835 return gfc_notify_std (standard
, "%s attribute "
836 "with %s attribute in %qs at %L",
837 a1
, a2
, name
, where
);
846 /* Mark a symbol as referenced. */
849 gfc_set_sym_referenced (gfc_symbol
*sym
)
852 if (sym
->attr
.referenced
)
855 sym
->attr
.referenced
= 1;
857 /* Remember which order dummy variables are accessed in. */
859 sym
->dummy_order
= next_dummy_order
++;
863 /* Common subroutine called by attribute changing subroutines in order
864 to prevent them from changing a symbol that has been
865 use-associated. Returns zero if it is OK to change the symbol,
869 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
872 if (attr
->use_assoc
== 0)
876 where
= &gfc_current_locus
;
879 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
882 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
889 /* Generate an error because of a duplicate attribute. */
892 duplicate_attr (const char *attr
, locus
*where
)
896 where
= &gfc_current_locus
;
898 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
903 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
904 locus
*where ATTRIBUTE_UNUSED
)
906 attr
->ext_attr
|= 1 << ext_attr
;
911 /* Called from decl.c (attr_decl1) to check attributes, when declared
915 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
917 if (check_used (attr
, NULL
, where
))
920 return check_conflict (attr
, NULL
, where
);
925 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
928 if (check_used (attr
, NULL
, where
))
931 if (attr
->allocatable
)
933 duplicate_attr ("ALLOCATABLE", where
);
937 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
938 && !gfc_find_state (COMP_INTERFACE
))
940 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
945 attr
->allocatable
= 1;
946 return check_conflict (attr
, NULL
, where
);
951 gfc_add_automatic (symbol_attribute
*attr
, const char *name
, locus
*where
)
953 if (check_used (attr
, name
, where
))
956 if (attr
->automatic
&& !gfc_notify_std (GFC_STD_LEGACY
,
957 "Duplicate AUTOMATIC attribute specified at %L", where
))
961 return check_conflict (attr
, name
, where
);
966 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
969 if (check_used (attr
, name
, where
))
972 if (attr
->codimension
)
974 duplicate_attr ("CODIMENSION", where
);
978 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
979 && !gfc_find_state (COMP_INTERFACE
))
981 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
982 "at %L", name
, where
);
986 attr
->codimension
= 1;
987 return check_conflict (attr
, name
, where
);
992 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
995 if (check_used (attr
, name
, where
))
1000 duplicate_attr ("DIMENSION", where
);
1004 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
1005 && !gfc_find_state (COMP_INTERFACE
))
1007 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1008 "at %L", name
, where
);
1012 attr
->dimension
= 1;
1013 return check_conflict (attr
, name
, where
);
1018 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1021 if (check_used (attr
, name
, where
))
1024 attr
->contiguous
= 1;
1025 return check_conflict (attr
, name
, where
);
1030 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
1033 if (check_used (attr
, NULL
, where
))
1038 duplicate_attr ("EXTERNAL", where
);
1042 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
1045 attr
->proc_pointer
= 1;
1050 return check_conflict (attr
, NULL
, where
);
1055 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
1058 if (check_used (attr
, NULL
, where
))
1061 if (attr
->intrinsic
)
1063 duplicate_attr ("INTRINSIC", where
);
1067 attr
->intrinsic
= 1;
1069 return check_conflict (attr
, NULL
, where
);
1074 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1077 if (check_used (attr
, NULL
, where
))
1082 duplicate_attr ("OPTIONAL", where
);
1087 return check_conflict (attr
, NULL
, where
);
1092 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1095 if (check_used (attr
, NULL
, where
))
1098 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1099 && !gfc_find_state (COMP_INTERFACE
)))
1101 duplicate_attr ("POINTER", where
);
1105 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1106 || (attr
->if_source
== IFSRC_IFBODY
1107 && !gfc_find_state (COMP_INTERFACE
)))
1108 attr
->proc_pointer
= 1;
1112 return check_conflict (attr
, NULL
, where
);
1117 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1120 if (check_used (attr
, NULL
, where
))
1123 attr
->cray_pointer
= 1;
1124 return check_conflict (attr
, NULL
, where
);
1129 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1132 if (check_used (attr
, NULL
, where
))
1135 if (attr
->cray_pointee
)
1137 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1138 " statements", where
);
1142 attr
->cray_pointee
= 1;
1143 return check_conflict (attr
, NULL
, where
);
1148 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1150 if (check_used (attr
, name
, where
))
1153 if (attr
->is_protected
)
1155 if (!gfc_notify_std (GFC_STD_LEGACY
,
1156 "Duplicate PROTECTED attribute specified at %L",
1161 attr
->is_protected
= 1;
1162 return check_conflict (attr
, name
, where
);
1167 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1170 if (check_used (attr
, name
, where
))
1174 return check_conflict (attr
, name
, where
);
1179 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1183 if (check_used (attr
, name
, where
))
1186 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1189 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1194 if (s
== SAVE_EXPLICIT
)
1195 gfc_unset_implicit_pure (NULL
);
1197 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1199 if (!gfc_notify_std (GFC_STD_LEGACY
,
1200 "Duplicate SAVE attribute specified at %L",
1206 return check_conflict (attr
, name
, where
);
1211 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1214 if (check_used (attr
, name
, where
))
1219 if (!gfc_notify_std (GFC_STD_LEGACY
,
1220 "Duplicate VALUE attribute specified at %L",
1226 return check_conflict (attr
, name
, where
);
1231 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1233 /* No check_used needed as 11.2.1 of the F2003 standard allows
1234 that the local identifier made accessible by a use statement can be
1235 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1237 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1238 if (!gfc_notify_std (GFC_STD_LEGACY
,
1239 "Duplicate VOLATILE attribute specified at %L",
1243 attr
->volatile_
= 1;
1244 attr
->volatile_ns
= gfc_current_ns
;
1245 return check_conflict (attr
, name
, where
);
1250 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1252 /* No check_used needed as 11.2.1 of the F2003 standard allows
1253 that the local identifier made accessible by a use statement can be
1254 given a ASYNCHRONOUS attribute. */
1256 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1257 if (!gfc_notify_std (GFC_STD_LEGACY
,
1258 "Duplicate ASYNCHRONOUS attribute specified at %L",
1262 attr
->asynchronous
= 1;
1263 attr
->asynchronous_ns
= gfc_current_ns
;
1264 return check_conflict (attr
, name
, where
);
1269 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1272 if (check_used (attr
, name
, where
))
1275 if (attr
->threadprivate
)
1277 duplicate_attr ("THREADPRIVATE", where
);
1281 attr
->threadprivate
= 1;
1282 return check_conflict (attr
, name
, where
);
1287 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1291 if (check_used (attr
, name
, where
))
1294 if (attr
->omp_declare_target
)
1297 attr
->omp_declare_target
= 1;
1298 return check_conflict (attr
, name
, where
);
1303 gfc_add_oacc_declare_create (symbol_attribute
*attr
, const char *name
,
1306 if (check_used (attr
, name
, where
))
1309 if (attr
->oacc_declare_create
)
1312 attr
->oacc_declare_create
= 1;
1313 return check_conflict (attr
, name
, where
);
1318 gfc_add_oacc_declare_copyin (symbol_attribute
*attr
, const char *name
,
1321 if (check_used (attr
, name
, where
))
1324 if (attr
->oacc_declare_copyin
)
1327 attr
->oacc_declare_copyin
= 1;
1328 return check_conflict (attr
, name
, where
);
1333 gfc_add_oacc_declare_deviceptr (symbol_attribute
*attr
, const char *name
,
1336 if (check_used (attr
, name
, where
))
1339 if (attr
->oacc_declare_deviceptr
)
1342 attr
->oacc_declare_deviceptr
= 1;
1343 return check_conflict (attr
, name
, where
);
1348 gfc_add_oacc_declare_device_resident (symbol_attribute
*attr
, const char *name
,
1351 if (check_used (attr
, name
, where
))
1354 if (attr
->oacc_declare_device_resident
)
1357 attr
->oacc_declare_device_resident
= 1;
1358 return check_conflict (attr
, name
, where
);
1363 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1366 if (check_used (attr
, NULL
, where
))
1371 duplicate_attr ("TARGET", where
);
1376 return check_conflict (attr
, NULL
, where
);
1381 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1384 if (check_used (attr
, name
, where
))
1387 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1389 return check_conflict (attr
, name
, where
);
1394 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1397 if (check_used (attr
, name
, where
))
1400 /* Duplicate attribute already checked for. */
1401 attr
->in_common
= 1;
1402 return check_conflict (attr
, name
, where
);
1407 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1410 /* Duplicate attribute already checked for. */
1411 attr
->in_equivalence
= 1;
1412 if (!check_conflict (attr
, name
, where
))
1415 if (attr
->flavor
== FL_VARIABLE
)
1418 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1423 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1426 if (check_used (attr
, name
, where
))
1430 return check_conflict (attr
, name
, where
);
1435 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1438 attr
->in_namelist
= 1;
1439 return check_conflict (attr
, name
, where
);
1444 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1447 if (check_used (attr
, name
, where
))
1451 return check_conflict (attr
, name
, where
);
1456 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1459 if (check_used (attr
, NULL
, where
))
1462 if (attr
->elemental
)
1464 duplicate_attr ("ELEMENTAL", where
);
1468 attr
->elemental
= 1;
1469 return check_conflict (attr
, NULL
, where
);
1474 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1477 if (check_used (attr
, NULL
, where
))
1482 duplicate_attr ("PURE", where
);
1487 return check_conflict (attr
, NULL
, where
);
1492 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1495 if (check_used (attr
, NULL
, where
))
1498 if (attr
->recursive
)
1500 duplicate_attr ("RECURSIVE", where
);
1504 attr
->recursive
= 1;
1505 return check_conflict (attr
, NULL
, where
);
1510 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1513 if (check_used (attr
, name
, where
))
1518 duplicate_attr ("ENTRY", where
);
1523 return check_conflict (attr
, name
, where
);
1528 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1531 if (attr
->flavor
!= FL_PROCEDURE
1532 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1536 return check_conflict (attr
, name
, where
);
1541 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1544 if (attr
->flavor
!= FL_PROCEDURE
1545 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1548 attr
->subroutine
= 1;
1549 return check_conflict (attr
, name
, where
);
1554 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1557 if (attr
->flavor
!= FL_PROCEDURE
1558 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1562 return check_conflict (attr
, name
, where
);
1567 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1570 if (check_used (attr
, NULL
, where
))
1573 if (attr
->flavor
!= FL_PROCEDURE
1574 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1577 if (attr
->procedure
)
1579 duplicate_attr ("PROCEDURE", where
);
1583 attr
->procedure
= 1;
1585 return check_conflict (attr
, NULL
, where
);
1590 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1594 duplicate_attr ("ABSTRACT", where
);
1600 return check_conflict (attr
, NULL
, where
);
1604 /* Flavors are special because some flavors are not what Fortran
1605 considers attributes and can be reaffirmed multiple times. */
1608 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1612 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1613 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| gfc_fl_struct(f
)
1614 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1617 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1620 if (attr
->flavor
!= FL_UNKNOWN
)
1623 where
= &gfc_current_locus
;
1626 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1627 gfc_code2string (flavors
, attr
->flavor
), name
,
1628 gfc_code2string (flavors
, f
), where
);
1630 gfc_error ("%s attribute conflicts with %s attribute at %L",
1631 gfc_code2string (flavors
, attr
->flavor
),
1632 gfc_code2string (flavors
, f
), where
);
1639 return check_conflict (attr
, name
, where
);
1644 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1645 const char *name
, locus
*where
)
1648 if (check_used (attr
, name
, where
))
1651 if (attr
->flavor
!= FL_PROCEDURE
1652 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1656 where
= &gfc_current_locus
;
1658 if (attr
->proc
!= PROC_UNKNOWN
&& !attr
->module_procedure
)
1660 if (attr
->proc
== PROC_ST_FUNCTION
&& t
== PROC_INTERNAL
1661 && !gfc_notification_std (GFC_STD_F2008
))
1662 gfc_error ("%s procedure at %L is already declared as %s "
1663 "procedure. \nF2008: A pointer function assignment "
1664 "is ambiguous if it is the first executable statement "
1665 "after the specification block. Please add any other "
1666 "kind of executable statement before it. FIXME",
1667 gfc_code2string (procedures
, t
), where
,
1668 gfc_code2string (procedures
, attr
->proc
));
1670 gfc_error ("%s procedure at %L is already declared as %s "
1671 "procedure", gfc_code2string (procedures
, t
), where
,
1672 gfc_code2string (procedures
, attr
->proc
));
1679 /* Statement functions are always scalar and functions. */
1680 if (t
== PROC_ST_FUNCTION
1681 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1682 || attr
->dimension
))
1685 return check_conflict (attr
, name
, where
);
1690 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1693 if (check_used (attr
, NULL
, where
))
1696 if (attr
->intent
== INTENT_UNKNOWN
)
1698 attr
->intent
= intent
;
1699 return check_conflict (attr
, NULL
, where
);
1703 where
= &gfc_current_locus
;
1705 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1706 gfc_intent_string (attr
->intent
),
1707 gfc_intent_string (intent
), where
);
1713 /* No checks for use-association in public and private statements. */
1716 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1717 const char *name
, locus
*where
)
1720 if (attr
->access
== ACCESS_UNKNOWN
1721 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1723 attr
->access
= access
;
1724 return check_conflict (attr
, name
, where
);
1728 where
= &gfc_current_locus
;
1729 gfc_error ("ACCESS specification at %L was already specified", where
);
1735 /* Set the is_bind_c field for the given symbol_attribute. */
1738 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1739 int is_proc_lang_bind_spec
)
1742 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1743 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1744 "variables or common blocks", where
);
1745 else if (attr
->is_bind_c
)
1746 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1748 attr
->is_bind_c
= 1;
1751 where
= &gfc_current_locus
;
1753 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1756 return check_conflict (attr
, name
, where
);
1760 /* Set the extension field for the given symbol_attribute. */
1763 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1766 where
= &gfc_current_locus
;
1768 if (attr
->extension
)
1769 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1771 attr
->extension
= 1;
1773 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1781 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1782 gfc_formal_arglist
* formal
, locus
*where
)
1784 if (check_used (&sym
->attr
, sym
->name
, where
))
1787 /* Skip the following checks in the case of a module_procedures in a
1788 submodule since they will manifestly fail. */
1789 if (sym
->attr
.module_procedure
== 1
1790 && source
== IFSRC_DECL
)
1794 where
= &gfc_current_locus
;
1796 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1797 && sym
->attr
.if_source
!= IFSRC_DECL
)
1799 gfc_error ("Symbol %qs at %L already has an explicit interface",
1804 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1806 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1807 "body", sym
->name
, where
);
1812 sym
->formal
= formal
;
1813 sym
->attr
.if_source
= source
;
1819 /* Add a type to a symbol. */
1822 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1828 where
= &gfc_current_locus
;
1831 type
= sym
->result
->ts
.type
;
1833 type
= sym
->ts
.type
;
1835 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1836 type
= sym
->ns
->proc_name
->ts
.type
;
1838 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
)
1839 && !(gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
1840 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
1841 && !sym
->attr
.module_procedure
)
1843 if (sym
->attr
.use_assoc
)
1844 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
1845 "use-associated at %L", sym
->name
, where
, sym
->module
,
1848 gfc_error ("Symbol %qs at %L already has basic type of %s", sym
->name
,
1849 where
, gfc_basic_typename (type
));
1853 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1855 gfc_error ("Procedure %qs at %L may not have basic type of %s",
1856 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1860 flavor
= sym
->attr
.flavor
;
1862 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1863 || flavor
== FL_LABEL
1864 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1865 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1867 gfc_error ("Symbol %qs at %L cannot have a type", sym
->name
, where
);
1876 /* Clears all attributes. */
1879 gfc_clear_attr (symbol_attribute
*attr
)
1881 memset (attr
, 0, sizeof (symbol_attribute
));
1885 /* Check for missing attributes in the new symbol. Currently does
1886 nothing, but it's not clear that it is unnecessary yet. */
1889 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1890 locus
*where ATTRIBUTE_UNUSED
)
1897 /* Copy an attribute to a symbol attribute, bit by bit. Some
1898 attributes have a lot of side-effects but cannot be present given
1899 where we are called from, so we ignore some bits. */
1902 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1904 int is_proc_lang_bind_spec
;
1906 /* In line with the other attributes, we only add bits but do not remove
1907 them; cf. also PR 41034. */
1908 dest
->ext_attr
|= src
->ext_attr
;
1910 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
1913 if (src
->automatic
&& !gfc_add_automatic (dest
, NULL
, where
))
1915 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
1917 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
1919 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
1921 if (src
->optional
&& !gfc_add_optional (dest
, where
))
1923 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
1925 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
1927 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
1929 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
1931 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
1933 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
1935 if (src
->threadprivate
1936 && !gfc_add_threadprivate (dest
, NULL
, where
))
1938 if (src
->omp_declare_target
1939 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
1941 if (src
->oacc_declare_create
1942 && !gfc_add_oacc_declare_create (dest
, NULL
, where
))
1944 if (src
->oacc_declare_copyin
1945 && !gfc_add_oacc_declare_copyin (dest
, NULL
, where
))
1947 if (src
->oacc_declare_deviceptr
1948 && !gfc_add_oacc_declare_deviceptr (dest
, NULL
, where
))
1950 if (src
->oacc_declare_device_resident
1951 && !gfc_add_oacc_declare_device_resident (dest
, NULL
, where
))
1953 if (src
->target
&& !gfc_add_target (dest
, where
))
1955 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
1957 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
1962 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
1965 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
1968 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
1970 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
1972 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
1975 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
1977 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
1979 if (src
->pure
&& !gfc_add_pure (dest
, where
))
1981 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
1984 if (src
->flavor
!= FL_UNKNOWN
1985 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
1988 if (src
->intent
!= INTENT_UNKNOWN
1989 && !gfc_add_intent (dest
, src
->intent
, where
))
1992 if (src
->access
!= ACCESS_UNKNOWN
1993 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
1996 if (!gfc_missing_attr (dest
, where
))
1999 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
2001 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
2004 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
2006 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
2009 if (src
->is_c_interop
)
2010 dest
->is_c_interop
= 1;
2014 if (src
->external
&& !gfc_add_external (dest
, where
))
2016 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
2018 if (src
->proc_pointer
)
2019 dest
->proc_pointer
= 1;
2028 /* A function to generate a dummy argument symbol using that from the
2029 interface declaration. Can be used for the result symbol as well if
2033 gfc_copy_dummy_sym (gfc_symbol
**dsym
, gfc_symbol
*sym
, int result
)
2037 rc
= gfc_get_symbol (sym
->name
, NULL
, dsym
);
2041 if (!gfc_add_type (*dsym
, &(sym
->ts
), &gfc_current_locus
))
2044 if (!gfc_copy_attr (&(*dsym
)->attr
, &(sym
->attr
),
2045 &gfc_current_locus
))
2048 if ((*dsym
)->attr
.dimension
)
2049 (*dsym
)->as
= gfc_copy_array_spec (sym
->as
);
2051 (*dsym
)->attr
.class_ok
= sym
->attr
.class_ok
;
2053 if ((*dsym
) != NULL
&& !result
2054 && (!gfc_add_dummy(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2055 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2057 else if ((*dsym
) != NULL
&& result
2058 && (!gfc_add_result(&(*dsym
)->attr
, (*dsym
)->name
, NULL
)
2059 || !gfc_missing_attr (&(*dsym
)->attr
, NULL
)))
2066 /************** Component name management ************/
2068 /* Component names of a derived type form their own little namespaces
2069 that are separate from all other spaces. The space is composed of
2070 a singly linked list of gfc_component structures whose head is
2071 located in the parent symbol. */
2074 /* Add a component name to a symbol. The call fails if the name is
2075 already present. On success, the component pointer is modified to
2076 point to the additional component structure. */
2079 gfc_add_component (gfc_symbol
*sym
, const char *name
,
2080 gfc_component
**component
)
2082 gfc_component
*p
, *tail
;
2084 /* Check for existing components with the same name, but not for union
2085 components or containers. Unions and maps are anonymous so they have
2086 unique internal names which will never conflict.
2087 Don't use gfc_find_component here because it calls gfc_use_derived,
2088 but the derived type may not be fully defined yet. */
2091 for (p
= sym
->components
; p
; p
= p
->next
)
2093 if (strcmp (p
->name
, name
) == 0)
2095 gfc_error ("Component %qs at %C already declared at %L",
2103 if (sym
->attr
.extension
2104 && gfc_find_component (sym
->components
->ts
.u
.derived
,
2105 name
, true, true, NULL
))
2107 gfc_error ("Component %qs at %C already in the parent type "
2108 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
2112 /* Allocate a new component. */
2113 p
= gfc_get_component ();
2116 sym
->components
= p
;
2120 p
->name
= gfc_get_string (name
);
2121 p
->loc
= gfc_current_locus
;
2122 p
->ts
.type
= BT_UNKNOWN
;
2129 /* Recursive function to switch derived types of all symbol in a
2133 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
2141 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
2142 sym
->ts
.u
.derived
= to
;
2144 switch_types (st
->left
, from
, to
);
2145 switch_types (st
->right
, from
, to
);
2149 /* This subroutine is called when a derived type is used in order to
2150 make the final determination about which version to use. The
2151 standard requires that a type be defined before it is 'used', but
2152 such types can appear in IMPLICIT statements before the actual
2153 definition. 'Using' in this context means declaring a variable to
2154 be that type or using the type constructor.
2156 If a type is used and the components haven't been defined, then we
2157 have to have a derived type in a parent unit. We find the node in
2158 the other namespace and point the symtree node in this namespace to
2159 that node. Further reference to this name point to the correct
2160 node. If we can't find the node in a parent namespace, then we have
2163 This subroutine takes a pointer to a symbol node and returns a
2164 pointer to the translated node or NULL for an error. Usually there
2165 is no translation and we return the node we were passed. */
2168 gfc_use_derived (gfc_symbol
*sym
)
2178 if (sym
->attr
.unlimited_polymorphic
)
2181 if (sym
->attr
.generic
)
2182 sym
= gfc_find_dt_in_generic (sym
);
2184 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
2185 return sym
; /* Already defined. */
2187 if (sym
->ns
->parent
== NULL
)
2190 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
2192 gfc_error ("Symbol %qs at %C is ambiguous", sym
->name
);
2196 if (s
== NULL
|| !gfc_fl_struct (s
->attr
.flavor
))
2199 /* Get rid of symbol sym, translating all references to s. */
2200 for (i
= 0; i
< GFC_LETTERS
; i
++)
2202 t
= &sym
->ns
->default_type
[i
];
2203 if (t
->u
.derived
== sym
)
2207 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2212 /* Unlink from list of modified symbols. */
2213 gfc_commit_symbol (sym
);
2215 switch_types (sym
->ns
->sym_root
, sym
, s
);
2217 /* TODO: Also have to replace sym -> s in other lists like
2218 namelists, common lists and interface lists. */
2219 gfc_free_symbol (sym
);
2224 gfc_error ("Derived type %qs at %C is being used before it is defined",
2230 /* Find the component with the given name in the union type symbol.
2231 If ref is not NULL it will be set to the chain of components through which
2232 the component can actually be accessed. This is necessary for unions because
2233 intermediate structures may be maps, nested structures, or other unions,
2234 all of which may (or must) be 'anonymous' to user code. */
2236 static gfc_component
*
2237 find_union_component (gfc_symbol
*un
, const char *name
,
2238 bool noaccess
, gfc_ref
**ref
)
2240 gfc_component
*m
, *check
;
2241 gfc_ref
*sref
, *tmp
;
2243 for (m
= un
->components
; m
; m
= m
->next
)
2245 check
= gfc_find_component (m
->ts
.u
.derived
, name
, noaccess
, true, &tmp
);
2249 /* Found component somewhere in m; chain the refs together. */
2253 sref
= gfc_get_ref ();
2254 sref
->type
= REF_COMPONENT
;
2255 sref
->u
.c
.component
= m
;
2256 sref
->u
.c
.sym
= m
->ts
.u
.derived
;
2261 /* Other checks (such as access) were done in the recursive calls. */
2268 /* Given a derived type node and a component name, try to locate the
2269 component structure. Returns the NULL pointer if the component is
2270 not found or the components are private. If noaccess is set, no access
2271 checks are done. If silent is set, an error will not be generated if
2272 the component cannot be found or accessed.
2274 If ref is not NULL, *ref is set to represent the chain of components
2275 required to get to the ultimate component.
2277 If the component is simply a direct subcomponent, or is inherited from a
2278 parent derived type in the given derived type, this is a single ref with its
2279 component set to the returned component.
2281 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2282 when the component is found through an implicit chain of nested union and
2283 map components. Unions and maps are "anonymous" substructures in FORTRAN
2284 which cannot be explicitly referenced, but the reference chain must be
2285 considered as in C for backend translation to correctly compute layouts.
2286 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2289 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2290 bool noaccess
, bool silent
, gfc_ref
**ref
)
2292 gfc_component
*p
, *check
;
2293 gfc_ref
*sref
= NULL
, *tmp
= NULL
;
2295 if (name
== NULL
|| sym
== NULL
)
2298 if (sym
->attr
.flavor
== FL_DERIVED
)
2299 sym
= gfc_use_derived (sym
);
2301 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
));
2306 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2307 if (sym
->attr
.flavor
== FL_UNION
)
2308 return find_union_component (sym
, name
, noaccess
, ref
);
2310 if (ref
) *ref
= NULL
;
2311 for (p
= sym
->components
; p
; p
= p
->next
)
2313 /* Nest search into union's maps. */
2314 if (p
->ts
.type
== BT_UNION
)
2316 check
= find_union_component (p
->ts
.u
.derived
, name
, noaccess
, &tmp
);
2322 sref
= gfc_get_ref ();
2323 sref
->type
= REF_COMPONENT
;
2324 sref
->u
.c
.component
= p
;
2325 sref
->u
.c
.sym
= p
->ts
.u
.derived
;
2332 else if (strcmp (p
->name
, name
) == 0)
2338 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2340 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2341 if (p
->attr
.access
== ACCESS_PRIVATE
||
2342 (p
->attr
.access
!= ACCESS_PUBLIC
2343 && sym
->component_access
== ACCESS_PRIVATE
2344 && !is_parent_comp
))
2347 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2354 && sym
->attr
.extension
2355 && sym
->components
->ts
.type
== BT_DERIVED
)
2357 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2358 noaccess
, silent
, ref
);
2359 /* Do not overwrite the error. */
2364 if (p
== NULL
&& !silent
)
2365 gfc_error ("%qs at %C is not a member of the %qs structure",
2368 /* Component was found; build the ultimate component reference. */
2369 if (p
!= NULL
&& ref
)
2371 tmp
= gfc_get_ref ();
2372 tmp
->type
= REF_COMPONENT
;
2373 tmp
->u
.c
.component
= p
;
2375 /* Link the final component ref to the end of the chain of subrefs. */
2379 for (; sref
->next
; sref
= sref
->next
)
2391 /* Given a symbol, free all of the component structures and everything
2395 free_components (gfc_component
*p
)
2403 gfc_free_array_spec (p
->as
);
2404 gfc_free_expr (p
->initializer
);
2412 /******************** Statement label management ********************/
2414 /* Comparison function for statement labels, used for managing the
2418 compare_st_labels (void *a1
, void *b1
)
2420 int a
= ((gfc_st_label
*) a1
)->value
;
2421 int b
= ((gfc_st_label
*) b1
)->value
;
2427 /* Free a single gfc_st_label structure, making sure the tree is not
2428 messed up. This function is called only when some parse error
2432 gfc_free_st_label (gfc_st_label
*label
)
2438 gfc_delete_bbt (&label
->ns
->st_labels
, label
, compare_st_labels
);
2440 if (label
->format
!= NULL
)
2441 gfc_free_expr (label
->format
);
2447 /* Free a whole tree of gfc_st_label structures. */
2450 free_st_labels (gfc_st_label
*label
)
2456 free_st_labels (label
->left
);
2457 free_st_labels (label
->right
);
2459 if (label
->format
!= NULL
)
2460 gfc_free_expr (label
->format
);
2465 /* Given a label number, search for and return a pointer to the label
2466 structure, creating it if it does not exist. */
2469 gfc_get_st_label (int labelno
)
2474 if (gfc_current_state () == COMP_DERIVED
)
2475 ns
= gfc_current_block ()->f2k_derived
;
2478 /* Find the namespace of the scoping unit:
2479 If we're in a BLOCK construct, jump to the parent namespace. */
2480 ns
= gfc_current_ns
;
2481 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2485 /* First see if the label is already in this namespace. */
2489 if (lp
->value
== labelno
)
2492 if (lp
->value
< labelno
)
2498 lp
= XCNEW (gfc_st_label
);
2500 lp
->value
= labelno
;
2501 lp
->defined
= ST_LABEL_UNKNOWN
;
2502 lp
->referenced
= ST_LABEL_UNKNOWN
;
2505 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2511 /* Called when a statement with a statement label is about to be
2512 accepted. We add the label to the list of the current namespace,
2513 making sure it hasn't been defined previously and referenced
2517 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2521 labelno
= lp
->value
;
2523 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2524 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2525 &lp
->where
, label_locus
);
2528 lp
->where
= *label_locus
;
2532 case ST_LABEL_FORMAT
:
2533 if (lp
->referenced
== ST_LABEL_TARGET
2534 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2535 gfc_error ("Label %d at %C already referenced as branch target",
2538 lp
->defined
= ST_LABEL_FORMAT
;
2542 case ST_LABEL_TARGET
:
2543 case ST_LABEL_DO_TARGET
:
2544 if (lp
->referenced
== ST_LABEL_FORMAT
)
2545 gfc_error ("Label %d at %C already referenced as a format label",
2550 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2551 && !gfc_notify_std (GFC_STD_F95_OBS
, "DO termination statement "
2552 "which is not END DO or CONTINUE with "
2553 "label %d at %C", labelno
))
2558 lp
->defined
= ST_LABEL_BAD_TARGET
;
2559 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2565 /* Reference a label. Given a label and its type, see if that
2566 reference is consistent with what is known about that label,
2567 updating the unknown state. Returns false if something goes
2571 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2573 gfc_sl_type label_type
;
2580 labelno
= lp
->value
;
2582 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2583 label_type
= lp
->defined
;
2586 label_type
= lp
->referenced
;
2587 lp
->where
= gfc_current_locus
;
2590 if (label_type
== ST_LABEL_FORMAT
2591 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2593 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2598 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2599 || label_type
== ST_LABEL_BAD_TARGET
)
2600 && type
== ST_LABEL_FORMAT
)
2602 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2607 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2608 && !gfc_notify_std (GFC_STD_F95_OBS
, "Shared DO termination label %d "
2612 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2613 lp
->referenced
= type
;
2621 /************** Symbol table management subroutines ****************/
2623 /* Basic details: Fortran 95 requires a potentially unlimited number
2624 of distinct namespaces when compiling a program unit. This case
2625 occurs during a compilation of internal subprograms because all of
2626 the internal subprograms must be read before we can start
2627 generating code for the host.
2629 Given the tricky nature of the Fortran grammar, we must be able to
2630 undo changes made to a symbol table if the current interpretation
2631 of a statement is found to be incorrect. Whenever a symbol is
2632 looked up, we make a copy of it and link to it. All of these
2633 symbols are kept in a vector so that we can commit or
2634 undo the changes at a later time.
2636 A symtree may point to a symbol node outside of its namespace. In
2637 this case, that symbol has been used as a host associated variable
2638 at some previous time. */
2640 /* Allocate a new namespace structure. Copies the implicit types from
2641 PARENT if PARENT_TYPES is set. */
2644 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2651 ns
= XCNEW (gfc_namespace
);
2652 ns
->sym_root
= NULL
;
2653 ns
->uop_root
= NULL
;
2654 ns
->tb_sym_root
= NULL
;
2655 ns
->finalizers
= NULL
;
2656 ns
->default_access
= ACCESS_UNKNOWN
;
2657 ns
->parent
= parent
;
2659 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2661 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2662 ns
->tb_op
[in
] = NULL
;
2665 /* Initialize default implicit types. */
2666 for (i
= 'a'; i
<= 'z'; i
++)
2668 ns
->set_flag
[i
- 'a'] = 0;
2669 ts
= &ns
->default_type
[i
- 'a'];
2671 if (parent_types
&& ns
->parent
!= NULL
)
2673 /* Copy parent settings. */
2674 *ts
= ns
->parent
->default_type
[i
- 'a'];
2678 if (flag_implicit_none
!= 0)
2684 if ('i' <= i
&& i
<= 'n')
2686 ts
->type
= BT_INTEGER
;
2687 ts
->kind
= gfc_default_integer_kind
;
2692 ts
->kind
= gfc_default_real_kind
;
2696 if (parent_types
&& ns
->parent
!= NULL
)
2697 ns
->has_implicit_none_export
= ns
->parent
->has_implicit_none_export
;
2705 /* Comparison function for symtree nodes. */
2708 compare_symtree (void *_st1
, void *_st2
)
2710 gfc_symtree
*st1
, *st2
;
2712 st1
= (gfc_symtree
*) _st1
;
2713 st2
= (gfc_symtree
*) _st2
;
2715 return strcmp (st1
->name
, st2
->name
);
2719 /* Allocate a new symtree node and associate it with the new symbol. */
2722 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2726 st
= XCNEW (gfc_symtree
);
2727 st
->name
= gfc_get_string (name
);
2729 gfc_insert_bbt (root
, st
, compare_symtree
);
2734 /* Delete a symbol from the tree. Does not free the symbol itself! */
2737 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2739 gfc_symtree st
, *st0
;
2741 st0
= gfc_find_symtree (*root
, name
);
2743 st
.name
= gfc_get_string (name
);
2744 gfc_delete_bbt (root
, &st
, compare_symtree
);
2750 /* Given a root symtree node and a name, try to find the symbol within
2751 the namespace. Returns NULL if the symbol is not found. */
2754 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2760 c
= strcmp (name
, st
->name
);
2764 st
= (c
< 0) ? st
->left
: st
->right
;
2771 /* Return a symtree node with a name that is guaranteed to be unique
2772 within the namespace and corresponds to an illegal fortran name. */
2775 gfc_get_unique_symtree (gfc_namespace
*ns
)
2777 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2778 static int serial
= 0;
2780 sprintf (name
, "@%d", serial
++);
2781 return gfc_new_symtree (&ns
->sym_root
, name
);
2785 /* Given a name find a user operator node, creating it if it doesn't
2786 exist. These are much simpler than symbols because they can't be
2787 ambiguous with one another. */
2790 gfc_get_uop (const char *name
)
2794 gfc_namespace
*ns
= gfc_current_ns
;
2798 st
= gfc_find_symtree (ns
->uop_root
, name
);
2802 st
= gfc_new_symtree (&ns
->uop_root
, name
);
2804 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2805 uop
->name
= gfc_get_string (name
);
2806 uop
->access
= ACCESS_UNKNOWN
;
2813 /* Given a name find the user operator node. Returns NULL if it does
2817 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2822 ns
= gfc_current_ns
;
2824 st
= gfc_find_symtree (ns
->uop_root
, name
);
2825 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2829 /* Update a symbol's common_block field, and take care of the associated
2830 memory management. */
2833 set_symbol_common_block (gfc_symbol
*sym
, gfc_common_head
*common_block
)
2835 if (sym
->common_block
== common_block
)
2838 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
2840 sym
->common_block
->refs
--;
2841 if (sym
->common_block
->refs
== 0)
2842 free (sym
->common_block
);
2844 sym
->common_block
= common_block
;
2848 /* Remove a gfc_symbol structure and everything it points to. */
2851 gfc_free_symbol (gfc_symbol
*sym
)
2857 gfc_free_array_spec (sym
->as
);
2859 free_components (sym
->components
);
2861 gfc_free_expr (sym
->value
);
2863 gfc_free_namelist (sym
->namelist
);
2865 if (sym
->ns
!= sym
->formal_ns
)
2866 gfc_free_namespace (sym
->formal_ns
);
2868 if (!sym
->attr
.generic_copy
)
2869 gfc_free_interface (sym
->generic
);
2871 gfc_free_formal_arglist (sym
->formal
);
2873 gfc_free_namespace (sym
->f2k_derived
);
2875 set_symbol_common_block (sym
, NULL
);
2881 /* Decrease the reference counter and free memory when we reach zero. */
2884 gfc_release_symbol (gfc_symbol
*sym
)
2889 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
2890 && (!sym
->attr
.entry
|| !sym
->module
))
2892 /* As formal_ns contains a reference to sym, delete formal_ns just
2893 before the deletion of sym. */
2894 gfc_namespace
*ns
= sym
->formal_ns
;
2895 sym
->formal_ns
= NULL
;
2896 gfc_free_namespace (ns
);
2903 gcc_assert (sym
->refs
== 0);
2904 gfc_free_symbol (sym
);
2908 /* Allocate and initialize a new symbol node. */
2911 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2915 p
= XCNEW (gfc_symbol
);
2917 gfc_clear_ts (&p
->ts
);
2918 gfc_clear_attr (&p
->attr
);
2921 p
->declared_at
= gfc_current_locus
;
2923 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2924 gfc_internal_error ("new_symbol(): Symbol name too long");
2926 p
->name
= gfc_get_string (name
);
2928 /* Make sure flags for symbol being C bound are clear initially. */
2929 p
->attr
.is_bind_c
= 0;
2930 p
->attr
.is_iso_c
= 0;
2932 /* Clear the ptrs we may need. */
2933 p
->common_block
= NULL
;
2934 p
->f2k_derived
= NULL
;
2941 /* Generate an error if a symbol is ambiguous. */
2944 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2947 if (st
->n
.sym
->module
)
2948 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
2949 "from module %qs", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2951 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
2952 "from current program unit", name
, st
->n
.sym
->name
);
2956 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2957 selector on the stack. If yes, replace it by the corresponding temporary. */
2960 select_type_insert_tmp (gfc_symtree
**st
)
2962 gfc_select_type_stack
*stack
= select_type_stack
;
2963 for (; stack
; stack
= stack
->prev
)
2964 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2967 select_type_insert_tmp (st
);
2973 /* Look for a symtree in the current procedure -- that is, go up to
2974 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2977 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
2981 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
2985 if (!ns
->construct_entities
)
2994 /* Search for a symtree starting in the current namespace, resorting to
2995 any parent namespaces if requested by a nonzero parent_flag.
2996 Returns nonzero if the name is ambiguous. */
2999 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3000 gfc_symtree
**result
)
3005 ns
= gfc_current_ns
;
3009 st
= gfc_find_symtree (ns
->sym_root
, name
);
3012 select_type_insert_tmp (&st
);
3015 /* Ambiguous generic interfaces are permitted, as long
3016 as the specific interfaces are different. */
3017 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3019 ambiguous_symbol (name
, st
);
3029 /* Don't escape an interface block. */
3030 if (ns
&& !ns
->has_import_set
3031 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3043 /* Same, but returns the symbol instead. */
3046 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
3047 gfc_symbol
**result
)
3052 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
3057 *result
= st
->n
.sym
;
3063 /* Tells whether there is only one set of changes in the stack. */
3066 single_undo_checkpoint_p (void)
3068 if (latest_undo_chgset
== &default_undo_chgset_var
)
3070 gcc_assert (latest_undo_chgset
->previous
== NULL
);
3075 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
3080 /* Save symbol with the information necessary to back it out. */
3083 gfc_save_symbol_data (gfc_symbol
*sym
)
3088 if (!single_undo_checkpoint_p ())
3090 /* If there is more than one change set, look for the symbol in the
3091 current one. If it is found there, we can reuse it. */
3092 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3095 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
3099 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
3102 s
= XCNEW (gfc_symbol
);
3104 sym
->old_symbol
= s
;
3107 latest_undo_chgset
->syms
.safe_push (sym
);
3111 /* Given a name, find a symbol, or create it if it does not exist yet
3112 in the current namespace. If the symbol is found we make sure that
3115 The integer return code indicates
3117 1 The symbol name was ambiguous
3118 2 The name meant to be established was already host associated.
3120 So if the return value is nonzero, then an error was issued. */
3123 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
3124 bool allow_subroutine
)
3129 /* This doesn't usually happen during resolution. */
3131 ns
= gfc_current_ns
;
3133 /* Try to find the symbol in ns. */
3134 st
= gfc_find_symtree (ns
->sym_root
, name
);
3136 if (st
== NULL
&& ns
->omp_udr_ns
)
3139 st
= gfc_find_symtree (ns
->sym_root
, name
);
3144 /* If not there, create a new symbol. */
3145 p
= gfc_new_symbol (name
, ns
);
3147 /* Add to the list of tentative symbols. */
3148 p
->old_symbol
= NULL
;
3151 latest_undo_chgset
->syms
.safe_push (p
);
3153 st
= gfc_new_symtree (&ns
->sym_root
, name
);
3160 /* Make sure the existing symbol is OK. Ambiguous
3161 generic interfaces are permitted, as long as the
3162 specific interfaces are different. */
3163 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
3165 ambiguous_symbol (name
, st
);
3170 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
3171 && !(allow_subroutine
&& p
->attr
.subroutine
)
3172 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
3173 && (ns
->has_import_set
|| p
->attr
.imported
)))
3175 /* Symbol is from another namespace. */
3176 gfc_error ("Symbol %qs at %C has already been host associated",
3183 /* Copy in case this symbol is changed. */
3184 gfc_save_symbol_data (p
);
3193 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
3198 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
3203 *result
= st
->n
.sym
;
3210 /* Subroutine that searches for a symbol, creating it if it doesn't
3211 exist, but tries to host-associate the symbol if possible. */
3214 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
3219 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
3223 gfc_save_symbol_data (st
->n
.sym
);
3228 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
3238 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
3243 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
3248 i
= gfc_get_ha_sym_tree (name
, &st
);
3251 *result
= st
->n
.sym
;
3259 /* Search for the symtree belonging to a gfc_common_head; we cannot use
3260 head->name as the common_root symtree's name might be mangled. */
3262 static gfc_symtree
*
3263 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
3266 gfc_symtree
*result
;
3271 if (st
->n
.common
== head
)
3274 result
= find_common_symtree (st
->left
, head
);
3276 result
= find_common_symtree (st
->right
, head
);
3282 /* Clear the given storage, and make it the current change set for registering
3283 changed symbols. Its contents are freed after a call to
3284 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
3285 it is up to the caller to free the storage itself. It is usually a local
3286 variable, so there is nothing to do anyway. */
3289 gfc_new_undo_checkpoint (gfc_undo_change_set
&chg_syms
)
3291 chg_syms
.syms
= vNULL
;
3292 chg_syms
.tbps
= vNULL
;
3293 chg_syms
.previous
= latest_undo_chgset
;
3294 latest_undo_chgset
= &chg_syms
;
3298 /* Restore previous state of symbol. Just copy simple stuff. */
3301 restore_old_symbol (gfc_symbol
*p
)
3306 old
= p
->old_symbol
;
3308 p
->ts
.type
= old
->ts
.type
;
3309 p
->ts
.kind
= old
->ts
.kind
;
3311 p
->attr
= old
->attr
;
3313 if (p
->value
!= old
->value
)
3315 gcc_checking_assert (old
->value
== NULL
);
3316 gfc_free_expr (p
->value
);
3320 if (p
->as
!= old
->as
)
3323 gfc_free_array_spec (p
->as
);
3327 p
->generic
= old
->generic
;
3328 p
->component_access
= old
->component_access
;
3330 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3332 gfc_free_namelist (p
->namelist
);
3337 if (p
->namelist_tail
!= old
->namelist_tail
)
3339 gfc_free_namelist (old
->namelist_tail
->next
);
3340 old
->namelist_tail
->next
= NULL
;
3344 p
->namelist_tail
= old
->namelist_tail
;
3346 if (p
->formal
!= old
->formal
)
3348 gfc_free_formal_arglist (p
->formal
);
3349 p
->formal
= old
->formal
;
3352 set_symbol_common_block (p
, old
->common_block
);
3353 p
->common_head
= old
->common_head
;
3355 p
->old_symbol
= old
->old_symbol
;
3360 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3361 the structure itself. */
3364 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3371 /* Given a change set pointer, free its target's contents and update it with
3372 the address of the previous change set. Note that only the contents are
3373 freed, not the target itself (the contents' container). It is not a problem
3374 as the latter will be a local variable usually. */
3377 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3379 free_undo_change_set_data (*cs
);
3384 static void free_old_symbol (gfc_symbol
*sym
);
3387 /* Merges the current change set into the previous one. The changes themselves
3388 are left untouched; only one checkpoint is forgotten. */
3391 gfc_drop_last_undo_checkpoint (void)
3396 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3398 /* No need to loop in this case. */
3399 if (s
->old_symbol
== NULL
)
3402 /* Remove the duplicate symbols. */
3403 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3406 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3408 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3409 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3410 shall contain from now on the backup symbol for S as it was
3411 at the checkpoint before. */
3412 if (s
->old_symbol
->gfc_new
)
3414 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3415 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3416 free_old_symbol (s
);
3419 restore_old_symbol (s
->old_symbol
);
3424 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3425 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3427 pop_undo_change_set (latest_undo_chgset
);
3431 /* Undoes all the changes made to symbols since the previous checkpoint.
3432 This subroutine is made simpler due to the fact that attributes are
3433 never removed once added. */
3436 gfc_restore_last_undo_checkpoint (void)
3441 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3443 /* Symbol in a common block was new. Or was old and just put in common */
3445 && (p
->gfc_new
|| !p
->old_symbol
->common_block
))
3447 /* If the symbol was added to any common block, it
3448 needs to be removed to stop the resolver looking
3449 for a (possibly) dead symbol. */
3450 if (p
->common_block
->head
== p
&& !p
->common_next
)
3452 gfc_symtree st
, *st0
;
3453 st0
= find_common_symtree (p
->ns
->common_root
,
3457 st
.name
= st0
->name
;
3458 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3463 if (p
->common_block
->head
== p
)
3464 p
->common_block
->head
= p
->common_next
;
3467 gfc_symbol
*cparent
, *csym
;
3469 cparent
= p
->common_block
->head
;
3470 csym
= cparent
->common_next
;
3475 csym
= csym
->common_next
;
3478 gcc_assert(cparent
->common_next
== p
);
3479 cparent
->common_next
= csym
->common_next
;
3481 p
->common_next
= NULL
;
3485 /* The derived type is saved in the symtree with the first
3486 letter capitalized; the all lower-case version to the
3487 derived type contains its associated generic function. */
3488 if (gfc_fl_struct (p
->attr
.flavor
))
3489 gfc_delete_symtree (&p
->ns
->sym_root
,gfc_dt_upper_string (p
->name
));
3491 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3493 gfc_release_symbol (p
);
3496 restore_old_symbol (p
);
3499 latest_undo_chgset
->syms
.truncate (0);
3500 latest_undo_chgset
->tbps
.truncate (0);
3502 if (!single_undo_checkpoint_p ())
3503 pop_undo_change_set (latest_undo_chgset
);
3507 /* Makes sure that there is only one set of changes; in other words we haven't
3508 forgotten to pair a call to gfc_new_checkpoint with a call to either
3509 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3512 enforce_single_undo_checkpoint (void)
3514 gcc_checking_assert (single_undo_checkpoint_p ());
3518 /* Undoes all the changes made to symbols in the current statement. */
3521 gfc_undo_symbols (void)
3523 enforce_single_undo_checkpoint ();
3524 gfc_restore_last_undo_checkpoint ();
3528 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3529 components of old_symbol that might need deallocation are the "allocatables"
3530 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3531 namelist_tail. In case these differ between old_symbol and sym, it's just
3532 because sym->namelist has gotten a few more items. */
3535 free_old_symbol (gfc_symbol
*sym
)
3538 if (sym
->old_symbol
== NULL
)
3541 if (sym
->old_symbol
->as
!= sym
->as
)
3542 gfc_free_array_spec (sym
->old_symbol
->as
);
3544 if (sym
->old_symbol
->value
!= sym
->value
)
3545 gfc_free_expr (sym
->old_symbol
->value
);
3547 if (sym
->old_symbol
->formal
!= sym
->formal
)
3548 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3550 free (sym
->old_symbol
);
3551 sym
->old_symbol
= NULL
;
3555 /* Makes the changes made in the current statement permanent-- gets
3556 rid of undo information. */
3559 gfc_commit_symbols (void)
3562 gfc_typebound_proc
*tbp
;
3565 enforce_single_undo_checkpoint ();
3567 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3571 free_old_symbol (p
);
3573 latest_undo_chgset
->syms
.truncate (0);
3575 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3577 latest_undo_chgset
->tbps
.truncate (0);
3581 /* Makes the changes made in one symbol permanent -- gets rid of undo
3585 gfc_commit_symbol (gfc_symbol
*sym
)
3590 enforce_single_undo_checkpoint ();
3592 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3595 latest_undo_chgset
->syms
.unordered_remove (i
);
3602 free_old_symbol (sym
);
3606 /* Recursively free trees containing type-bound procedures. */
3609 free_tb_tree (gfc_symtree
*t
)
3614 free_tb_tree (t
->left
);
3615 free_tb_tree (t
->right
);
3617 /* TODO: Free type-bound procedure structs themselves; probably needs some
3618 sort of ref-counting mechanism. */
3624 /* Recursive function that deletes an entire tree and all the common
3625 head structures it points to. */
3628 free_common_tree (gfc_symtree
* common_tree
)
3630 if (common_tree
== NULL
)
3633 free_common_tree (common_tree
->left
);
3634 free_common_tree (common_tree
->right
);
3640 /* Recursive function that deletes an entire tree and all the common
3641 head structures it points to. */
3644 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3646 if (omp_udr_tree
== NULL
)
3649 free_omp_udr_tree (omp_udr_tree
->left
);
3650 free_omp_udr_tree (omp_udr_tree
->right
);
3652 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3653 free (omp_udr_tree
);
3657 /* Recursive function that deletes an entire tree and all the user
3658 operator nodes that it contains. */
3661 free_uop_tree (gfc_symtree
*uop_tree
)
3663 if (uop_tree
== NULL
)
3666 free_uop_tree (uop_tree
->left
);
3667 free_uop_tree (uop_tree
->right
);
3669 gfc_free_interface (uop_tree
->n
.uop
->op
);
3670 free (uop_tree
->n
.uop
);
3675 /* Recursive function that deletes an entire tree and all the symbols
3676 that it contains. */
3679 free_sym_tree (gfc_symtree
*sym_tree
)
3681 if (sym_tree
== NULL
)
3684 free_sym_tree (sym_tree
->left
);
3685 free_sym_tree (sym_tree
->right
);
3687 gfc_release_symbol (sym_tree
->n
.sym
);
3692 /* Free the derived type list. */
3695 gfc_free_dt_list (void)
3697 gfc_dt_list
*dt
, *n
;
3699 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3705 gfc_derived_types
= NULL
;
3709 /* Free the gfc_equiv_info's. */
3712 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3716 gfc_free_equiv_infos (s
->next
);
3721 /* Free the gfc_equiv_lists. */
3724 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3728 gfc_free_equiv_lists (l
->next
);
3729 gfc_free_equiv_infos (l
->equiv
);
3734 /* Free a finalizer procedure list. */
3737 gfc_free_finalizer (gfc_finalizer
* el
)
3741 gfc_release_symbol (el
->proc_sym
);
3747 gfc_free_finalizer_list (gfc_finalizer
* list
)
3751 gfc_finalizer
* current
= list
;
3753 gfc_free_finalizer (current
);
3758 /* Create a new gfc_charlen structure and add it to a namespace.
3759 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3762 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3765 cl
= gfc_get_charlen ();
3770 /* Put into namespace, but don't allow reject_statement
3771 to free it if old_cl is given. */
3772 gfc_charlen
**prev
= &ns
->cl_list
;
3773 cl
->next
= ns
->old_cl_list
;
3774 while (*prev
!= ns
->old_cl_list
)
3775 prev
= &(*prev
)->next
;
3777 ns
->old_cl_list
= cl
;
3778 cl
->length
= gfc_copy_expr (old_cl
->length
);
3779 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3780 cl
->backend_decl
= old_cl
->backend_decl
;
3781 cl
->passed_length
= old_cl
->passed_length
;
3782 cl
->resolved
= old_cl
->resolved
;
3786 /* Put into namespace. */
3787 cl
->next
= ns
->cl_list
;
3795 /* Free the charlen list from cl to end (end is not freed).
3796 Free the whole list if end is NULL. */
3799 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3803 for (; cl
!= end
; cl
= cl2
)
3808 gfc_free_expr (cl
->length
);
3814 /* Free entry list structs. */
3817 free_entry_list (gfc_entry_list
*el
)
3819 gfc_entry_list
*next
;
3826 free_entry_list (next
);
3830 /* Free a namespace structure and everything below it. Interface
3831 lists associated with intrinsic operators are not freed. These are
3832 taken care of when a specific name is freed. */
3835 gfc_free_namespace (gfc_namespace
*ns
)
3837 gfc_namespace
*p
, *q
;
3846 gcc_assert (ns
->refs
== 0);
3848 gfc_free_statements (ns
->code
);
3850 free_sym_tree (ns
->sym_root
);
3851 free_uop_tree (ns
->uop_root
);
3852 free_common_tree (ns
->common_root
);
3853 free_omp_udr_tree (ns
->omp_udr_root
);
3854 free_tb_tree (ns
->tb_sym_root
);
3855 free_tb_tree (ns
->tb_uop_root
);
3856 gfc_free_finalizer_list (ns
->finalizers
);
3857 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
3858 gfc_free_charlen (ns
->cl_list
, NULL
);
3859 free_st_labels (ns
->st_labels
);
3861 free_entry_list (ns
->entries
);
3862 gfc_free_equiv (ns
->equiv
);
3863 gfc_free_equiv_lists (ns
->equiv_lists
);
3864 gfc_free_use_stmts (ns
->use_stmts
);
3866 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3867 gfc_free_interface (ns
->op
[i
]);
3869 gfc_free_data (ns
->data
);
3873 /* Recursively free any contained namespaces. */
3878 gfc_free_namespace (q
);
3884 gfc_symbol_init_2 (void)
3887 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3892 gfc_symbol_done_2 (void)
3894 gfc_free_namespace (gfc_current_ns
);
3895 gfc_current_ns
= NULL
;
3896 gfc_free_dt_list ();
3898 enforce_single_undo_checkpoint ();
3899 free_undo_change_set_data (*latest_undo_chgset
);
3903 /* Count how many nodes a symtree has. */
3906 count_st_nodes (const gfc_symtree
*st
)
3912 nodes
= count_st_nodes (st
->left
);
3914 nodes
+= count_st_nodes (st
->right
);
3920 /* Convert symtree tree into symtree vector. */
3923 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
3928 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
3929 st_vec
[node_cntr
++] = st
;
3930 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
3936 /* Traverse namespace. As the functions might modify the symtree, we store the
3937 symtree as a vector and operate on this vector. Note: We assume that
3938 sym_func or st_func never deletes nodes from the symtree - only adding is
3939 allowed. Additionally, newly added nodes are not traversed. */
3942 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
3943 void (*sym_func
) (gfc_symbol
*))
3945 gfc_symtree
**st_vec
;
3946 unsigned nodes
, i
, node_cntr
;
3948 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
3949 nodes
= count_st_nodes (st
);
3950 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
3952 fill_st_vector (st
, st_vec
, node_cntr
);
3957 for (i
= 0; i
< nodes
; i
++)
3958 st_vec
[i
]->n
.sym
->mark
= 0;
3959 for (i
= 0; i
< nodes
; i
++)
3960 if (!st_vec
[i
]->n
.sym
->mark
)
3962 (*sym_func
) (st_vec
[i
]->n
.sym
);
3963 st_vec
[i
]->n
.sym
->mark
= 1;
3967 for (i
= 0; i
< nodes
; i
++)
3968 (*st_func
) (st_vec
[i
]);
3972 /* Recursively traverse the symtree nodes. */
3975 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
3977 do_traverse_symtree (st
, st_func
, NULL
);
3981 /* Call a given function for all symbols in the namespace. We take
3982 care that each gfc_symbol node is called exactly once. */
3985 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
3987 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
3991 /* Return TRUE when name is the name of an intrinsic type. */
3994 gfc_is_intrinsic_typename (const char *name
)
3996 if (strcmp (name
, "integer") == 0
3997 || strcmp (name
, "real") == 0
3998 || strcmp (name
, "character") == 0
3999 || strcmp (name
, "logical") == 0
4000 || strcmp (name
, "complex") == 0
4001 || strcmp (name
, "doubleprecision") == 0
4002 || strcmp (name
, "doublecomplex") == 0)
4009 /* Return TRUE if the symbol is an automatic variable. */
4012 gfc_is_var_automatic (gfc_symbol
*sym
)
4014 /* Pointer and allocatable variables are never automatic. */
4015 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4017 /* Check for arrays with non-constant size. */
4018 if (sym
->attr
.dimension
&& sym
->as
4019 && !gfc_is_compile_time_shape (sym
->as
))
4021 /* Check for non-constant length character variables. */
4022 if (sym
->ts
.type
== BT_CHARACTER
4024 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
4026 /* Variables with explicit AUTOMATIC attribute. */
4027 if (sym
->attr
.automatic
)
4033 /* Given a symbol, mark it as SAVEd if it is allowed. */
4036 save_symbol (gfc_symbol
*sym
)
4039 if (sym
->attr
.use_assoc
)
4042 if (sym
->attr
.in_common
4045 || sym
->attr
.flavor
!= FL_VARIABLE
)
4047 /* Automatic objects are not saved. */
4048 if (gfc_is_var_automatic (sym
))
4050 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
4054 /* Mark those symbols which can be SAVEd as such. */
4057 gfc_save_all (gfc_namespace
*ns
)
4059 gfc_traverse_ns (ns
, save_symbol
);
4063 /* Make sure that no changes to symbols are pending. */
4066 gfc_enforce_clean_symbol_state(void)
4068 enforce_single_undo_checkpoint ();
4069 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
4073 /************** Global symbol handling ************/
4076 /* Search a tree for the global symbol. */
4079 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
4088 c
= strcmp (name
, symbol
->name
);
4092 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
4099 /* Compare two global symbols. Used for managing the BB tree. */
4102 gsym_compare (void *_s1
, void *_s2
)
4104 gfc_gsymbol
*s1
, *s2
;
4106 s1
= (gfc_gsymbol
*) _s1
;
4107 s2
= (gfc_gsymbol
*) _s2
;
4108 return strcmp (s1
->name
, s2
->name
);
4112 /* Get a global symbol, creating it if it doesn't exist. */
4115 gfc_get_gsymbol (const char *name
)
4119 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
4123 s
= XCNEW (gfc_gsymbol
);
4124 s
->type
= GSYM_UNKNOWN
;
4125 s
->name
= gfc_get_string (name
);
4127 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
4134 get_iso_c_binding_dt (int sym_id
)
4136 gfc_dt_list
*dt_list
;
4138 dt_list
= gfc_derived_types
;
4140 /* Loop through the derived types in the name list, searching for
4141 the desired symbol from iso_c_binding. Search the parent namespaces
4142 if necessary and requested to (parent_flag). */
4143 while (dt_list
!= NULL
)
4145 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
4146 && dt_list
->derived
->intmod_sym_id
== sym_id
)
4147 return dt_list
->derived
;
4149 dt_list
= dt_list
->next
;
4156 /* Verifies that the given derived type symbol, derived_sym, is interoperable
4157 with C. This is necessary for any derived type that is BIND(C) and for
4158 derived types that are parameters to functions that are BIND(C). All
4159 fields of the derived type are required to be interoperable, and are tested
4160 for such. If an error occurs, the errors are reported here, allowing for
4161 multiple errors to be handled for a single derived type. */
4164 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
4166 gfc_component
*curr_comp
= NULL
;
4167 bool is_c_interop
= false;
4170 if (derived_sym
== NULL
)
4171 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4172 "unexpectedly NULL");
4174 /* If we've already looked at this derived symbol, do not look at it again
4175 so we don't repeat warnings/errors. */
4176 if (derived_sym
->ts
.is_c_interop
)
4179 /* The derived type must have the BIND attribute to be interoperable
4180 J3/04-007, Section 15.2.3. */
4181 if (derived_sym
->attr
.is_bind_c
!= 1)
4183 derived_sym
->ts
.is_c_interop
= 0;
4184 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4185 "attribute to be C interoperable", derived_sym
->name
,
4186 &(derived_sym
->declared_at
));
4190 curr_comp
= derived_sym
->components
;
4192 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4193 empty struct. Section 15.2 in Fortran 2003 states: "The following
4194 subclauses define the conditions under which a Fortran entity is
4195 interoperable. If a Fortran entity is interoperable, an equivalent
4196 entity may be defined by means of C and the Fortran entity is said
4197 to be interoperable with the C entity. There does not have to be such
4198 an interoperating C entity."
4200 if (curr_comp
== NULL
)
4202 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4203 "and may be inaccessible by the C companion processor",
4204 derived_sym
->name
, &(derived_sym
->declared_at
));
4205 derived_sym
->ts
.is_c_interop
= 1;
4206 derived_sym
->attr
.is_bind_c
= 1;
4211 /* Initialize the derived type as being C interoperable.
4212 If we find an error in the components, this will be set false. */
4213 derived_sym
->ts
.is_c_interop
= 1;
4215 /* Loop through the list of components to verify that the kind of
4216 each is a C interoperable type. */
4219 /* The components cannot be pointers (fortran sense).
4220 J3/04-007, Section 15.2.3, C1505. */
4221 if (curr_comp
->attr
.pointer
!= 0)
4223 gfc_error ("Component %qs at %L cannot have the "
4224 "POINTER attribute because it is a member "
4225 "of the BIND(C) derived type %qs at %L",
4226 curr_comp
->name
, &(curr_comp
->loc
),
4227 derived_sym
->name
, &(derived_sym
->declared_at
));
4231 if (curr_comp
->attr
.proc_pointer
!= 0)
4233 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4234 " of the BIND(C) derived type %qs at %L", curr_comp
->name
,
4235 &curr_comp
->loc
, derived_sym
->name
,
4236 &derived_sym
->declared_at
);
4240 /* The components cannot be allocatable.
4241 J3/04-007, Section 15.2.3, C1505. */
4242 if (curr_comp
->attr
.allocatable
!= 0)
4244 gfc_error ("Component %qs at %L cannot have the "
4245 "ALLOCATABLE attribute because it is a member "
4246 "of the BIND(C) derived type %qs at %L",
4247 curr_comp
->name
, &(curr_comp
->loc
),
4248 derived_sym
->name
, &(derived_sym
->declared_at
));
4252 /* BIND(C) derived types must have interoperable components. */
4253 if (curr_comp
->ts
.type
== BT_DERIVED
4254 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
4255 && curr_comp
->ts
.u
.derived
!= derived_sym
)
4257 /* This should be allowed; the draft says a derived-type can not
4258 have type parameters if it is has the BIND attribute. Type
4259 parameters seem to be for making parameterized derived types.
4260 There's no need to verify the type if it is c_ptr/c_funptr. */
4261 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
4265 /* Grab the typespec for the given component and test the kind. */
4266 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
4270 /* Report warning and continue since not fatal. The
4271 draft does specify a constraint that requires all fields
4272 to interoperate, but if the user says real(4), etc., it
4273 may interoperate with *something* in C, but the compiler
4274 most likely won't know exactly what. Further, it may not
4275 interoperate with the same data type(s) in C if the user
4276 recompiles with different flags (e.g., -m32 and -m64 on
4277 x86_64 and using integer(4) to claim interop with a
4279 if (derived_sym
->attr
.is_bind_c
== 1 && warn_c_binding_type
)
4280 /* If the derived type is bind(c), all fields must be
4282 gfc_warning (OPT_Wc_binding_type
,
4283 "Component %qs in derived type %qs at %L "
4284 "may not be C interoperable, even though "
4285 "derived type %qs is BIND(C)",
4286 curr_comp
->name
, derived_sym
->name
,
4287 &(curr_comp
->loc
), derived_sym
->name
);
4288 else if (warn_c_binding_type
)
4289 /* If derived type is param to bind(c) routine, or to one
4290 of the iso_c_binding procs, it must be interoperable, so
4291 all fields must interop too. */
4292 gfc_warning (OPT_Wc_binding_type
,
4293 "Component %qs in derived type %qs at %L "
4294 "may not be C interoperable",
4295 curr_comp
->name
, derived_sym
->name
,
4300 curr_comp
= curr_comp
->next
;
4301 } while (curr_comp
!= NULL
);
4304 /* Make sure we don't have conflicts with the attributes. */
4305 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
4307 gfc_error ("Derived type %qs at %L cannot be declared with both "
4308 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
4309 &(derived_sym
->declared_at
));
4313 if (derived_sym
->attr
.sequence
!= 0)
4315 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4316 "attribute because it is BIND(C)", derived_sym
->name
,
4317 &(derived_sym
->declared_at
));
4321 /* Mark the derived type as not being C interoperable if we found an
4322 error. If there were only warnings, proceed with the assumption
4323 it's interoperable. */
4325 derived_sym
->ts
.is_c_interop
= 0;
4331 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4334 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4338 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4339 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4341 tmp_sym
->attr
.is_c_interop
= 1;
4342 tmp_sym
->attr
.is_bind_c
= 1;
4343 tmp_sym
->ts
.is_c_interop
= 1;
4344 tmp_sym
->ts
.is_iso_c
= 1;
4345 tmp_sym
->ts
.type
= BT_DERIVED
;
4346 tmp_sym
->ts
.f90_type
= BT_VOID
;
4347 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4348 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4350 /* Set the c_address field of c_null_ptr and c_null_funptr to
4351 the value of NULL. */
4352 tmp_sym
->value
= gfc_get_expr ();
4353 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4354 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4355 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4356 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4357 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4358 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4359 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4360 c
->expr
->ts
.is_iso_c
= 1;
4366 /* Add a formal argument, gfc_formal_arglist, to the
4367 end of the given list of arguments. Set the reference to the
4368 provided symbol, param_sym, in the argument. */
4371 add_formal_arg (gfc_formal_arglist
**head
,
4372 gfc_formal_arglist
**tail
,
4373 gfc_formal_arglist
*formal_arg
,
4374 gfc_symbol
*param_sym
)
4376 /* Put in list, either as first arg or at the tail (curr arg). */
4378 *head
= *tail
= formal_arg
;
4381 (*tail
)->next
= formal_arg
;
4382 (*tail
) = formal_arg
;
4385 (*tail
)->sym
= param_sym
;
4386 (*tail
)->next
= NULL
;
4392 /* Add a procedure interface to the given symbol (i.e., store a
4393 reference to the list of formal arguments). */
4396 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4399 sym
->formal
= formal
;
4400 sym
->attr
.if_source
= source
;
4404 /* Copy the formal args from an existing symbol, src, into a new
4405 symbol, dest. New formal args are created, and the description of
4406 each arg is set according to the existing ones. This function is
4407 used when creating procedure declaration variables from a procedure
4408 declaration statement (see match_proc_decl()) to create the formal
4409 args based on the args of a given named interface.
4411 When an actual argument list is provided, skip the absent arguments.
4412 To be used together with gfc_se->ignore_optional. */
4415 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
,
4416 gfc_actual_arglist
*actual
)
4418 gfc_formal_arglist
*head
= NULL
;
4419 gfc_formal_arglist
*tail
= NULL
;
4420 gfc_formal_arglist
*formal_arg
= NULL
;
4421 gfc_intrinsic_arg
*curr_arg
= NULL
;
4422 gfc_formal_arglist
*formal_prev
= NULL
;
4423 gfc_actual_arglist
*act_arg
= actual
;
4424 /* Save current namespace so we can change it for formal args. */
4425 gfc_namespace
*parent_ns
= gfc_current_ns
;
4427 /* Create a new namespace, which will be the formal ns (namespace
4428 of the formal args). */
4429 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4430 gfc_current_ns
->proc_name
= dest
;
4432 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4434 /* Skip absent arguments. */
4437 gcc_assert (act_arg
!= NULL
);
4438 if (act_arg
->expr
== NULL
)
4440 act_arg
= act_arg
->next
;
4443 act_arg
= act_arg
->next
;
4445 formal_arg
= gfc_get_formal_arglist ();
4446 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4448 /* May need to copy more info for the symbol. */
4449 formal_arg
->sym
->ts
= curr_arg
->ts
;
4450 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4451 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4452 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4453 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4454 formal_arg
->sym
->attr
.dummy
= 1;
4456 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4457 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4459 /* If this isn't the first arg, set up the next ptr. For the
4460 last arg built, the formal_arg->next will never get set to
4461 anything other than NULL. */
4462 if (formal_prev
!= NULL
)
4463 formal_prev
->next
= formal_arg
;
4465 formal_arg
->next
= NULL
;
4467 formal_prev
= formal_arg
;
4469 /* Add arg to list of formal args. */
4470 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4472 /* Validate changes. */
4473 gfc_commit_symbol (formal_arg
->sym
);
4476 /* Add the interface to the symbol. */
4477 add_proc_interface (dest
, IFSRC_DECL
, head
);
4479 /* Store the formal namespace information. */
4480 if (dest
->formal
!= NULL
)
4481 /* The current ns should be that for the dest proc. */
4482 dest
->formal_ns
= gfc_current_ns
;
4483 /* Restore the current namespace to what it was on entry. */
4484 gfc_current_ns
= parent_ns
;
4489 std_for_isocbinding_symbol (int id
)
4493 #define NAMED_INTCST(a,b,c,d) \
4496 #include "iso-c-binding.def"
4499 #define NAMED_FUNCTION(a,b,c,d) \
4502 #define NAMED_SUBROUTINE(a,b,c,d) \
4505 #include "iso-c-binding.def"
4506 #undef NAMED_FUNCTION
4507 #undef NAMED_SUBROUTINE
4510 return GFC_STD_F2003
;
4514 /* Generate the given set of C interoperable kind objects, or all
4515 interoperable kinds. This function will only be given kind objects
4516 for valid iso_c_binding defined types because this is verified when
4517 the 'use' statement is parsed. If the user gives an 'only' clause,
4518 the specific kinds are looked up; if they don't exist, an error is
4519 reported. If the user does not give an 'only' clause, all
4520 iso_c_binding symbols are generated. If a list of specific kinds
4521 is given, it must have a NULL in the first empty spot to mark the
4522 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4523 point to the symtree for c_(fun)ptr. */
4526 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4527 const char *local_name
, gfc_symtree
*dt_symtree
,
4530 const char *const name
= (local_name
&& local_name
[0])
4531 ? local_name
: c_interop_kinds_table
[s
].name
;
4532 gfc_symtree
*tmp_symtree
;
4533 gfc_symbol
*tmp_sym
= NULL
;
4536 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4539 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4541 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4542 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4543 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4546 /* Already exists in this scope so don't re-add it. */
4547 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4548 && (!tmp_sym
->attr
.generic
4549 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4550 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4552 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4553 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4555 gfc_dt_list
*dt_list
;
4556 dt_list
= gfc_get_dt_list ();
4557 dt_list
->derived
= tmp_sym
;
4558 dt_list
->next
= gfc_derived_types
;
4559 gfc_derived_types
= dt_list
;
4565 /* Create the sym tree in the current ns. */
4568 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4569 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4571 /* Add to the list of tentative symbols. */
4572 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4573 tmp_sym
->old_symbol
= NULL
;
4575 tmp_sym
->gfc_new
= 1;
4577 tmp_symtree
->n
.sym
= tmp_sym
;
4582 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4583 gcc_assert (tmp_symtree
);
4584 tmp_sym
= tmp_symtree
->n
.sym
;
4587 /* Say what module this symbol belongs to. */
4588 tmp_sym
->module
= gfc_get_string (mod_name
);
4589 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4590 tmp_sym
->intmod_sym_id
= s
;
4591 tmp_sym
->attr
.is_iso_c
= 1;
4592 tmp_sym
->attr
.use_assoc
= 1;
4594 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4595 || s
== ISOCBINDING_NULL_PTR
);
4600 #define NAMED_INTCST(a,b,c,d) case a :
4601 #define NAMED_REALCST(a,b,c,d) case a :
4602 #define NAMED_CMPXCST(a,b,c,d) case a :
4603 #define NAMED_LOGCST(a,b,c) case a :
4604 #define NAMED_CHARKNDCST(a,b,c) case a :
4605 #include "iso-c-binding.def"
4607 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4608 c_interop_kinds_table
[s
].value
);
4610 /* Initialize an integer constant expression node. */
4611 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4612 tmp_sym
->ts
.type
= BT_INTEGER
;
4613 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4615 /* Mark this type as a C interoperable one. */
4616 tmp_sym
->ts
.is_c_interop
= 1;
4617 tmp_sym
->ts
.is_iso_c
= 1;
4618 tmp_sym
->value
->ts
.is_c_interop
= 1;
4619 tmp_sym
->value
->ts
.is_iso_c
= 1;
4620 tmp_sym
->attr
.is_c_interop
= 1;
4622 /* Tell what f90 type this c interop kind is valid. */
4623 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4628 #define NAMED_CHARCST(a,b,c) case a :
4629 #include "iso-c-binding.def"
4631 /* Initialize an integer constant expression node for the
4632 length of the character. */
4633 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4634 &gfc_current_locus
, NULL
, 1);
4635 tmp_sym
->value
->ts
.is_c_interop
= 1;
4636 tmp_sym
->value
->ts
.is_iso_c
= 1;
4637 tmp_sym
->value
->value
.character
.length
= 1;
4638 tmp_sym
->value
->value
.character
.string
[0]
4639 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4640 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4641 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4644 /* May not need this in both attr and ts, but do need in
4645 attr for writing module file. */
4646 tmp_sym
->attr
.is_c_interop
= 1;
4648 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4649 tmp_sym
->ts
.type
= BT_CHARACTER
;
4651 /* Need to set it to the C_CHAR kind. */
4652 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4654 /* Mark this type as a C interoperable one. */
4655 tmp_sym
->ts
.is_c_interop
= 1;
4656 tmp_sym
->ts
.is_iso_c
= 1;
4658 /* Tell what f90 type this c interop kind is valid. */
4659 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4663 case ISOCBINDING_PTR
:
4664 case ISOCBINDING_FUNPTR
:
4667 gfc_dt_list
**dt_list_ptr
= NULL
;
4668 gfc_component
*tmp_comp
= NULL
;
4670 /* Generate real derived type. */
4675 const char *hidden_name
;
4676 gfc_interface
*intr
, *head
;
4678 hidden_name
= gfc_dt_upper_string (tmp_sym
->name
);
4679 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4681 gcc_assert (tmp_symtree
== NULL
);
4682 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4683 dt_sym
= tmp_symtree
->n
.sym
;
4684 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4685 ? "c_ptr" : "c_funptr");
4687 /* Generate an artificial generic function. */
4688 head
= tmp_sym
->generic
;
4689 intr
= gfc_get_interface ();
4691 intr
->where
= gfc_current_locus
;
4693 tmp_sym
->generic
= intr
;
4695 if (!tmp_sym
->attr
.generic
4696 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4699 if (!tmp_sym
->attr
.function
4700 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4704 /* Say what module this symbol belongs to. */
4705 dt_sym
->module
= gfc_get_string (mod_name
);
4706 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4707 dt_sym
->intmod_sym_id
= s
;
4708 dt_sym
->attr
.use_assoc
= 1;
4710 /* Initialize an integer constant expression node. */
4711 dt_sym
->attr
.flavor
= FL_DERIVED
;
4712 dt_sym
->ts
.is_c_interop
= 1;
4713 dt_sym
->attr
.is_c_interop
= 1;
4714 dt_sym
->attr
.private_comp
= 1;
4715 dt_sym
->component_access
= ACCESS_PRIVATE
;
4716 dt_sym
->ts
.is_iso_c
= 1;
4717 dt_sym
->ts
.type
= BT_DERIVED
;
4718 dt_sym
->ts
.f90_type
= BT_VOID
;
4720 /* A derived type must have the bind attribute to be
4721 interoperable (J3/04-007, Section 15.2.3), even though
4722 the binding label is not used. */
4723 dt_sym
->attr
.is_bind_c
= 1;
4725 dt_sym
->attr
.referenced
= 1;
4726 dt_sym
->ts
.u
.derived
= dt_sym
;
4728 /* Add the symbol created for the derived type to the current ns. */
4729 dt_list_ptr
= &(gfc_derived_types
);
4730 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4731 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4733 /* There is already at least one derived type in the list, so append
4734 the one we're currently building for c_ptr or c_funptr. */
4735 if (*dt_list_ptr
!= NULL
)
4736 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4737 (*dt_list_ptr
) = gfc_get_dt_list ();
4738 (*dt_list_ptr
)->derived
= dt_sym
;
4739 (*dt_list_ptr
)->next
= NULL
;
4741 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4742 if (tmp_comp
== NULL
)
4745 tmp_comp
->ts
.type
= BT_INTEGER
;
4747 /* Set this because the module will need to read/write this field. */
4748 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4750 /* The kinds for c_ptr and c_funptr are the same. */
4751 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4752 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4753 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4755 /* Mark the component as C interoperable. */
4756 tmp_comp
->ts
.is_c_interop
= 1;
4761 case ISOCBINDING_NULL_PTR
:
4762 case ISOCBINDING_NULL_FUNPTR
:
4763 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4769 gfc_commit_symbol (tmp_sym
);
4774 /* Check that a symbol is already typed. If strict is not set, an untyped
4775 symbol is acceptable for non-standard-conforming mode. */
4778 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4779 bool strict
, locus where
)
4783 if (gfc_matching_prefix
)
4786 /* Check for the type and try to give it an implicit one. */
4787 if (sym
->ts
.type
== BT_UNKNOWN
4788 && !gfc_set_default_type (sym
, 0, ns
))
4792 gfc_error ("Symbol %qs is used before it is typed at %L",
4797 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol %qs is used before"
4798 " it is typed at %L", sym
->name
, &where
))
4802 /* Everything is ok. */
4807 /* Construct a typebound-procedure structure. Those are stored in a tentative
4808 list and marked `error' until symbols are committed. */
4811 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4813 gfc_typebound_proc
*result
;
4815 result
= XCNEW (gfc_typebound_proc
);
4820 latest_undo_chgset
->tbps
.safe_push (result
);
4826 /* Get the super-type of a given derived type. */
4829 gfc_get_derived_super_type (gfc_symbol
* derived
)
4831 gcc_assert (derived
);
4833 if (derived
->attr
.generic
)
4834 derived
= gfc_find_dt_in_generic (derived
);
4836 if (!derived
->attr
.extension
)
4839 gcc_assert (derived
->components
);
4840 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4841 gcc_assert (derived
->components
->ts
.u
.derived
);
4843 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4844 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4846 return derived
->components
->ts
.u
.derived
;
4850 /* Get the ultimate super-type of a given derived type. */
4853 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4855 if (!derived
->attr
.extension
)
4858 derived
= gfc_get_derived_super_type (derived
);
4860 if (derived
->attr
.extension
)
4861 return gfc_get_ultimate_derived_super_type (derived
);
4867 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4870 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4872 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4873 t2
= gfc_get_derived_super_type (t2
);
4874 return gfc_compare_derived_types (t1
, t2
);
4878 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4879 If ts1 is nonpolymorphic, ts2 must be the same type.
4880 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4883 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4885 bool is_class1
= (ts1
->type
== BT_CLASS
);
4886 bool is_class2
= (ts2
->type
== BT_CLASS
);
4887 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4888 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4889 bool is_union1
= (ts1
->type
== BT_UNION
);
4890 bool is_union2
= (ts2
->type
== BT_UNION
);
4893 && ts1
->u
.derived
->components
4894 && ((ts1
->u
.derived
->attr
.is_class
4895 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
4896 .unlimited_polymorphic
)
4897 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
4900 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
4901 && !is_union1
&& !is_union2
)
4902 return (ts1
->type
== ts2
->type
);
4904 if ((is_derived1
&& is_derived2
) || (is_union1
&& is_union2
))
4905 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4907 if (is_derived1
&& is_class2
)
4908 return gfc_compare_derived_types (ts1
->u
.derived
,
4909 ts2
->u
.derived
->attr
.is_class
?
4910 ts2
->u
.derived
->components
->ts
.u
.derived
4912 if (is_class1
&& is_derived2
)
4913 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
4914 ts1
->u
.derived
->components
->ts
.u
.derived
4917 else if (is_class1
&& is_class2
)
4918 return gfc_type_is_extension_of (ts1
->u
.derived
->attr
.is_class
?
4919 ts1
->u
.derived
->components
->ts
.u
.derived
4921 ts2
->u
.derived
->attr
.is_class
?
4922 ts2
->u
.derived
->components
->ts
.u
.derived
4929 /* Find the parent-namespace of the current function. If we're inside
4930 BLOCK constructs, it may not be the current one. */
4933 gfc_find_proc_namespace (gfc_namespace
* ns
)
4935 while (ns
->construct_entities
)
4945 /* Check if an associate-variable should be translated as an `implicit' pointer
4946 internally (if it is associated to a variable and not an array with
4950 gfc_is_associate_pointer (gfc_symbol
* sym
)
4955 if (sym
->ts
.type
== BT_CLASS
)
4958 if (!sym
->assoc
->variable
)
4961 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
4969 gfc_find_dt_in_generic (gfc_symbol
*sym
)
4971 gfc_interface
*intr
= NULL
;
4973 if (!sym
|| gfc_fl_struct (sym
->attr
.flavor
))
4976 if (sym
->attr
.generic
)
4977 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
4978 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
4980 return intr
? intr
->sym
: NULL
;
4984 /* Get the dummy arguments from a procedure symbol. If it has been declared
4985 via a PROCEDURE statement with a named interface, ts.interface will be set
4986 and the arguments need to be taken from there. */
4988 gfc_formal_arglist
*
4989 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
4991 gfc_formal_arglist
*dummies
;
4993 dummies
= sym
->formal
;
4994 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
4995 dummies
= sym
->ts
.interface
->formal
;