1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2014 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
),
46 const mstring procedures
[] =
48 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
49 minit ("MODULE-PROC", PROC_MODULE
),
50 minit ("INTERNAL-PROC", PROC_INTERNAL
),
51 minit ("DUMMY-PROC", PROC_DUMMY
),
52 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
53 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
54 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
58 const mstring intents
[] =
60 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
61 minit ("IN", INTENT_IN
),
62 minit ("OUT", INTENT_OUT
),
63 minit ("INOUT", INTENT_INOUT
),
67 const mstring access_types
[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
70 minit ("PUBLIC", ACCESS_PUBLIC
),
71 minit ("PRIVATE", ACCESS_PRIVATE
),
75 const mstring ifsrc_types
[] =
77 minit ("UNKNOWN", IFSRC_UNKNOWN
),
78 minit ("DECL", IFSRC_DECL
),
79 minit ("BODY", IFSRC_IFBODY
)
82 const mstring save_status
[] =
84 minit ("UNKNOWN", SAVE_NONE
),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order
= 1;
95 gfc_namespace
*gfc_current_ns
;
96 gfc_namespace
*gfc_global_ns_list
;
98 gfc_gsymbol
*gfc_gsym_root
= NULL
;
100 gfc_dt_list
*gfc_derived_types
;
102 static gfc_undo_change_set default_undo_chgset_var
= { vNULL
, vNULL
, NULL
};
103 static gfc_undo_change_set
*latest_undo_chgset
= &default_undo_chgset_var
;
106 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
108 /* The following static variable indicates whether a particular element has
109 been explicitly set or not. */
111 static int new_flag
[GFC_LETTERS
];
114 /* Handle a correctly parsed IMPLICIT NONE. */
117 gfc_set_implicit_none (void)
121 if (gfc_current_ns
->seen_implicit_none
)
123 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
127 gfc_current_ns
->seen_implicit_none
= 1;
129 for (i
= 0; i
< GFC_LETTERS
; i
++)
131 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
132 gfc_current_ns
->set_flag
[i
] = 1;
137 /* Reset the implicit range flags. */
140 gfc_clear_new_implicit (void)
144 for (i
= 0; i
< GFC_LETTERS
; i
++)
149 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
152 gfc_add_new_implicit_range (int c1
, int c2
)
159 for (i
= c1
; i
<= c2
; i
++)
163 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
175 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
176 the new implicit types back into the existing types will work. */
179 gfc_merge_new_implicit (gfc_typespec
*ts
)
183 if (gfc_current_ns
->seen_implicit_none
)
185 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
189 for (i
= 0; i
< GFC_LETTERS
; i
++)
193 if (gfc_current_ns
->set_flag
[i
])
195 gfc_error ("Letter %c already has an IMPLICIT type at %C",
200 gfc_current_ns
->default_type
[i
] = *ts
;
201 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
202 gfc_current_ns
->set_flag
[i
] = 1;
209 /* Given a symbol, return a pointer to the typespec for its default type. */
212 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
218 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
219 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
220 "gfortran developers, and should not be used for "
221 "implicitly typed variables");
223 if (letter
< 'a' || letter
> 'z')
224 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name
);
229 return &ns
->default_type
[letter
- 'a'];
233 /* Given a pointer to a symbol, set its type according to the first
234 letter of its name. Fails if the letter in question has no default
238 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
242 if (sym
->ts
.type
!= BT_UNKNOWN
)
243 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
245 ts
= gfc_get_default_type (sym
->name
, ns
);
247 if (ts
->type
== BT_UNKNOWN
)
249 if (error_flag
&& !sym
->attr
.untyped
)
251 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
252 sym
->name
, &sym
->declared_at
);
253 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
260 sym
->attr
.implicit_type
= 1;
262 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
263 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
264 else if (ts
->type
== BT_CLASS
265 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
268 if (sym
->attr
.is_bind_c
== 1 && gfc_option
.warn_c_binding_type
)
270 /* BIND(C) variables should not be implicitly declared. */
271 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
272 "not be C interoperable", sym
->name
, &sym
->declared_at
);
273 sym
->ts
.f90_type
= sym
->ts
.type
;
276 if (sym
->attr
.dummy
!= 0)
278 if (sym
->ns
->proc_name
!= NULL
279 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
280 || sym
->ns
->proc_name
->attr
.function
!= 0)
281 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0
282 && gfc_option
.warn_c_binding_type
)
284 /* Dummy args to a BIND(C) routine may not be interoperable if
285 they are implicitly typed. */
286 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
287 "be C interoperable but it is a dummy argument to "
288 "the BIND(C) procedure '%s' at %L", sym
->name
,
289 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
290 &(sym
->ns
->proc_name
->declared_at
));
291 sym
->ts
.f90_type
= sym
->ts
.type
;
299 /* This function is called from parse.c(parse_progunit) to check the
300 type of the function is not implicitly typed in the host namespace
301 and to implicitly type the function result, if necessary. */
304 gfc_check_function_type (gfc_namespace
*ns
)
306 gfc_symbol
*proc
= ns
->proc_name
;
308 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
311 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
313 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
))
315 if (proc
->result
!= proc
)
317 proc
->ts
= proc
->result
->ts
;
318 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
319 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
320 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
321 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
324 else if (!proc
->result
->attr
.proc_pointer
)
326 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
327 proc
->result
->name
, &proc
->result
->declared_at
);
328 proc
->result
->attr
.untyped
= 1;
334 /******************** Symbol attribute stuff *********************/
336 /* This is a generic conflict-checker. We do this to avoid having a
337 single conflict in two places. */
339 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
340 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
341 #define conf_std(a, b, std) if (attr->a && attr->b)\
350 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
352 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
353 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
354 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
355 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
356 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
357 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
358 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
359 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
360 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
361 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
362 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
363 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
364 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
365 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
366 *proc_pointer
= "PROCEDURE POINTER", *abstract
= "ABSTRACT",
367 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
368 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC";
369 static const char *threadprivate
= "THREADPRIVATE";
370 static const char *omp_declare_target
= "OMP DECLARE TARGET";
376 where
= &gfc_current_locus
;
378 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
382 standard
= GFC_STD_F2003
;
386 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
389 a2
= attr
->allocatable
? allocatable
: pointer
;
390 standard
= GFC_STD_F2003
;
394 /* Check for attributes not allowed in a BLOCK DATA. */
395 if (gfc_current_state () == COMP_BLOCK_DATA
)
399 if (attr
->in_namelist
)
401 if (attr
->allocatable
)
407 if (attr
->access
== ACCESS_PRIVATE
)
409 if (attr
->access
== ACCESS_PUBLIC
)
411 if (attr
->intent
!= INTENT_UNKNOWN
)
417 ("%s attribute not allowed in BLOCK DATA program unit at %L",
423 if (attr
->save
== SAVE_EXPLICIT
)
426 conf (in_common
, save
);
429 switch (attr
->flavor
)
437 a1
= gfc_code2string (flavors
, attr
->flavor
);
441 gfc_error ("Namelist group name at %L cannot have the "
442 "SAVE attribute", where
);
446 /* Conflicts between SAVE and PROCEDURE will be checked at
447 resolution stage, see "resolve_fl_procedure". */
455 conf (dummy
, intrinsic
);
456 conf (dummy
, threadprivate
);
457 conf (dummy
, omp_declare_target
);
458 conf (pointer
, target
);
459 conf (pointer
, intrinsic
);
460 conf (pointer
, elemental
);
461 conf (allocatable
, elemental
);
463 conf (target
, external
);
464 conf (target
, intrinsic
);
466 if (!attr
->if_source
)
467 conf (external
, dimension
); /* See Fortran 95's R504. */
469 conf (external
, intrinsic
);
470 conf (entry
, intrinsic
);
472 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
473 conf (external
, subroutine
);
475 if (attr
->proc_pointer
&& !gfc_notify_std (GFC_STD_F2003
,
476 "Procedure pointer at %C"))
479 conf (allocatable
, pointer
);
480 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
481 conf_std (allocatable
, function
, GFC_STD_F2003
);
482 conf_std (allocatable
, result
, GFC_STD_F2003
);
483 conf (elemental
, recursive
);
485 conf (in_common
, dummy
);
486 conf (in_common
, allocatable
);
487 conf (in_common
, codimension
);
488 conf (in_common
, result
);
490 conf (in_equivalence
, use_assoc
);
491 conf (in_equivalence
, codimension
);
492 conf (in_equivalence
, dummy
);
493 conf (in_equivalence
, target
);
494 conf (in_equivalence
, pointer
);
495 conf (in_equivalence
, function
);
496 conf (in_equivalence
, result
);
497 conf (in_equivalence
, entry
);
498 conf (in_equivalence
, allocatable
);
499 conf (in_equivalence
, threadprivate
);
500 conf (in_equivalence
, omp_declare_target
);
502 conf (dummy
, result
);
503 conf (entry
, result
);
504 conf (generic
, result
);
506 conf (function
, subroutine
);
508 if (!function
&& !subroutine
)
509 conf (is_bind_c
, dummy
);
511 conf (is_bind_c
, cray_pointer
);
512 conf (is_bind_c
, cray_pointee
);
513 conf (is_bind_c
, codimension
);
514 conf (is_bind_c
, allocatable
);
515 conf (is_bind_c
, elemental
);
517 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
518 Parameter conflict caught below. Also, value cannot be specified
519 for a dummy procedure. */
521 /* Cray pointer/pointee conflicts. */
522 conf (cray_pointer
, cray_pointee
);
523 conf (cray_pointer
, dimension
);
524 conf (cray_pointer
, codimension
);
525 conf (cray_pointer
, contiguous
);
526 conf (cray_pointer
, pointer
);
527 conf (cray_pointer
, target
);
528 conf (cray_pointer
, allocatable
);
529 conf (cray_pointer
, external
);
530 conf (cray_pointer
, intrinsic
);
531 conf (cray_pointer
, in_namelist
);
532 conf (cray_pointer
, function
);
533 conf (cray_pointer
, subroutine
);
534 conf (cray_pointer
, entry
);
536 conf (cray_pointee
, allocatable
);
537 conf (cray_pointer
, contiguous
);
538 conf (cray_pointer
, codimension
);
539 conf (cray_pointee
, intent
);
540 conf (cray_pointee
, optional
);
541 conf (cray_pointee
, dummy
);
542 conf (cray_pointee
, target
);
543 conf (cray_pointee
, intrinsic
);
544 conf (cray_pointee
, pointer
);
545 conf (cray_pointee
, entry
);
546 conf (cray_pointee
, in_common
);
547 conf (cray_pointee
, in_equivalence
);
548 conf (cray_pointee
, threadprivate
);
549 conf (cray_pointee
, omp_declare_target
);
552 conf (data
, function
);
554 conf (data
, allocatable
);
556 conf (value
, pointer
)
557 conf (value
, allocatable
)
558 conf (value
, subroutine
)
559 conf (value
, function
)
560 conf (value
, volatile_
)
561 conf (value
, dimension
)
562 conf (value
, codimension
)
563 conf (value
, external
)
565 conf (codimension
, result
)
568 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
571 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
575 conf (is_protected
, intrinsic
)
576 conf (is_protected
, in_common
)
578 conf (asynchronous
, intrinsic
)
579 conf (asynchronous
, external
)
581 conf (volatile_
, intrinsic
)
582 conf (volatile_
, external
)
584 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
591 conf (procedure
, allocatable
)
592 conf (procedure
, dimension
)
593 conf (procedure
, codimension
)
594 conf (procedure
, intrinsic
)
595 conf (procedure
, target
)
596 conf (procedure
, value
)
597 conf (procedure
, volatile_
)
598 conf (procedure
, asynchronous
)
599 conf (procedure
, entry
)
601 conf (proc_pointer
, abstract
)
603 conf (entry
, omp_declare_target
)
605 a1
= gfc_code2string (flavors
, attr
->flavor
);
607 if (attr
->in_namelist
608 && attr
->flavor
!= FL_VARIABLE
609 && attr
->flavor
!= FL_PROCEDURE
610 && attr
->flavor
!= FL_UNKNOWN
)
616 switch (attr
->flavor
)
626 conf2 (asynchronous
);
629 conf2 (is_protected
);
639 conf2 (threadprivate
);
640 conf2 (omp_declare_target
);
642 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
644 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
645 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
652 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
666 /* Conflicts with INTENT, SAVE and RESULT will be checked
667 at resolution stage, see "resolve_fl_procedure". */
669 if (attr
->subroutine
)
675 conf2 (asynchronous
);
680 if (!attr
->proc_pointer
)
681 conf2 (threadprivate
);
684 if (!attr
->proc_pointer
)
689 case PROC_ST_FUNCTION
:
700 conf2 (threadprivate
);
720 conf2 (threadprivate
);
722 conf2 (omp_declare_target
);
724 if (attr
->intent
!= INTENT_UNKNOWN
)
741 conf2 (is_protected
);
747 conf2 (asynchronous
);
748 conf2 (threadprivate
);
764 gfc_error ("%s attribute conflicts with %s attribute at %L",
767 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
768 a1
, a2
, name
, where
);
775 return gfc_notify_std (standard
, "%s attribute "
776 "with %s attribute at %L", a1
, a2
,
781 return gfc_notify_std (standard
, "%s attribute "
782 "with %s attribute in '%s' at %L",
783 a1
, a2
, name
, where
);
792 /* Mark a symbol as referenced. */
795 gfc_set_sym_referenced (gfc_symbol
*sym
)
798 if (sym
->attr
.referenced
)
801 sym
->attr
.referenced
= 1;
803 /* Remember which order dummy variables are accessed in. */
805 sym
->dummy_order
= next_dummy_order
++;
809 /* Common subroutine called by attribute changing subroutines in order
810 to prevent them from changing a symbol that has been
811 use-associated. Returns zero if it is OK to change the symbol,
815 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
818 if (attr
->use_assoc
== 0)
822 where
= &gfc_current_locus
;
825 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
828 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
835 /* Generate an error because of a duplicate attribute. */
838 duplicate_attr (const char *attr
, locus
*where
)
842 where
= &gfc_current_locus
;
844 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
849 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
850 locus
*where ATTRIBUTE_UNUSED
)
852 attr
->ext_attr
|= 1 << ext_attr
;
857 /* Called from decl.c (attr_decl1) to check attributes, when declared
861 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
863 if (check_used (attr
, NULL
, where
))
866 return check_conflict (attr
, NULL
, where
);
871 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
874 if (check_used (attr
, NULL
, where
))
877 if (attr
->allocatable
)
879 duplicate_attr ("ALLOCATABLE", where
);
883 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
884 && !gfc_find_state (COMP_INTERFACE
))
886 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
891 attr
->allocatable
= 1;
892 return check_conflict (attr
, NULL
, where
);
897 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
900 if (check_used (attr
, name
, where
))
903 if (attr
->codimension
)
905 duplicate_attr ("CODIMENSION", where
);
909 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
910 && !gfc_find_state (COMP_INTERFACE
))
912 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
913 "at %L", name
, where
);
917 attr
->codimension
= 1;
918 return check_conflict (attr
, name
, where
);
923 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
926 if (check_used (attr
, name
, where
))
931 duplicate_attr ("DIMENSION", where
);
935 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
936 && !gfc_find_state (COMP_INTERFACE
))
938 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
939 "at %L", name
, where
);
944 return check_conflict (attr
, name
, where
);
949 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
952 if (check_used (attr
, name
, where
))
955 attr
->contiguous
= 1;
956 return check_conflict (attr
, name
, where
);
961 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
964 if (check_used (attr
, NULL
, where
))
969 duplicate_attr ("EXTERNAL", where
);
973 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
976 attr
->proc_pointer
= 1;
981 return check_conflict (attr
, NULL
, where
);
986 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
989 if (check_used (attr
, NULL
, where
))
994 duplicate_attr ("INTRINSIC", where
);
1000 return check_conflict (attr
, NULL
, where
);
1005 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1008 if (check_used (attr
, NULL
, where
))
1013 duplicate_attr ("OPTIONAL", where
);
1018 return check_conflict (attr
, NULL
, where
);
1023 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1026 if (check_used (attr
, NULL
, where
))
1029 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1030 && !gfc_find_state (COMP_INTERFACE
)))
1032 duplicate_attr ("POINTER", where
);
1036 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1037 || (attr
->if_source
== IFSRC_IFBODY
1038 && !gfc_find_state (COMP_INTERFACE
)))
1039 attr
->proc_pointer
= 1;
1043 return check_conflict (attr
, NULL
, where
);
1048 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1051 if (check_used (attr
, NULL
, where
))
1054 attr
->cray_pointer
= 1;
1055 return check_conflict (attr
, NULL
, where
);
1060 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1063 if (check_used (attr
, NULL
, where
))
1066 if (attr
->cray_pointee
)
1068 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1069 " statements", where
);
1073 attr
->cray_pointee
= 1;
1074 return check_conflict (attr
, NULL
, where
);
1079 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1081 if (check_used (attr
, name
, where
))
1084 if (attr
->is_protected
)
1086 if (!gfc_notify_std (GFC_STD_LEGACY
,
1087 "Duplicate PROTECTED attribute specified at %L",
1092 attr
->is_protected
= 1;
1093 return check_conflict (attr
, name
, where
);
1098 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1101 if (check_used (attr
, name
, where
))
1105 return check_conflict (attr
, name
, where
);
1110 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1114 if (check_used (attr
, name
, where
))
1117 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1120 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1125 if (s
== SAVE_EXPLICIT
)
1126 gfc_unset_implicit_pure (NULL
);
1128 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1130 if (!gfc_notify_std (GFC_STD_LEGACY
,
1131 "Duplicate SAVE attribute specified at %L",
1137 return check_conflict (attr
, name
, where
);
1142 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1145 if (check_used (attr
, name
, where
))
1150 if (!gfc_notify_std (GFC_STD_LEGACY
,
1151 "Duplicate VALUE attribute specified at %L",
1157 return check_conflict (attr
, name
, where
);
1162 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1164 /* No check_used needed as 11.2.1 of the F2003 standard allows
1165 that the local identifier made accessible by a use statement can be
1166 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1168 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1169 if (!gfc_notify_std (GFC_STD_LEGACY
,
1170 "Duplicate VOLATILE attribute specified at %L",
1174 attr
->volatile_
= 1;
1175 attr
->volatile_ns
= gfc_current_ns
;
1176 return check_conflict (attr
, name
, where
);
1181 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1183 /* No check_used needed as 11.2.1 of the F2003 standard allows
1184 that the local identifier made accessible by a use statement can be
1185 given a ASYNCHRONOUS attribute. */
1187 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1188 if (!gfc_notify_std (GFC_STD_LEGACY
,
1189 "Duplicate ASYNCHRONOUS attribute specified at %L",
1193 attr
->asynchronous
= 1;
1194 attr
->asynchronous_ns
= gfc_current_ns
;
1195 return check_conflict (attr
, name
, where
);
1200 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1203 if (check_used (attr
, name
, where
))
1206 if (attr
->threadprivate
)
1208 duplicate_attr ("THREADPRIVATE", where
);
1212 attr
->threadprivate
= 1;
1213 return check_conflict (attr
, name
, where
);
1218 gfc_add_omp_declare_target (symbol_attribute
*attr
, const char *name
,
1222 if (check_used (attr
, name
, where
))
1225 if (attr
->omp_declare_target
)
1228 attr
->omp_declare_target
= 1;
1229 return check_conflict (attr
, name
, where
);
1234 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1237 if (check_used (attr
, NULL
, where
))
1242 duplicate_attr ("TARGET", where
);
1247 return check_conflict (attr
, NULL
, where
);
1252 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1255 if (check_used (attr
, name
, where
))
1258 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1260 return check_conflict (attr
, name
, where
);
1265 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1268 if (check_used (attr
, name
, where
))
1271 /* Duplicate attribute already checked for. */
1272 attr
->in_common
= 1;
1273 return check_conflict (attr
, name
, where
);
1278 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1281 /* Duplicate attribute already checked for. */
1282 attr
->in_equivalence
= 1;
1283 if (!check_conflict (attr
, name
, where
))
1286 if (attr
->flavor
== FL_VARIABLE
)
1289 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1294 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1297 if (check_used (attr
, name
, where
))
1301 return check_conflict (attr
, name
, where
);
1306 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1309 attr
->in_namelist
= 1;
1310 return check_conflict (attr
, name
, where
);
1315 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1318 if (check_used (attr
, name
, where
))
1322 return check_conflict (attr
, name
, where
);
1327 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1330 if (check_used (attr
, NULL
, where
))
1333 if (attr
->elemental
)
1335 duplicate_attr ("ELEMENTAL", where
);
1339 attr
->elemental
= 1;
1340 return check_conflict (attr
, NULL
, where
);
1345 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1348 if (check_used (attr
, NULL
, where
))
1353 duplicate_attr ("PURE", where
);
1358 return check_conflict (attr
, NULL
, where
);
1363 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1366 if (check_used (attr
, NULL
, where
))
1369 if (attr
->recursive
)
1371 duplicate_attr ("RECURSIVE", where
);
1375 attr
->recursive
= 1;
1376 return check_conflict (attr
, NULL
, where
);
1381 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1384 if (check_used (attr
, name
, where
))
1389 duplicate_attr ("ENTRY", where
);
1394 return check_conflict (attr
, name
, where
);
1399 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1402 if (attr
->flavor
!= FL_PROCEDURE
1403 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1407 return check_conflict (attr
, name
, where
);
1412 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1415 if (attr
->flavor
!= FL_PROCEDURE
1416 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1419 attr
->subroutine
= 1;
1420 return check_conflict (attr
, name
, where
);
1425 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1428 if (attr
->flavor
!= FL_PROCEDURE
1429 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1433 return check_conflict (attr
, name
, where
);
1438 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1441 if (check_used (attr
, NULL
, where
))
1444 if (attr
->flavor
!= FL_PROCEDURE
1445 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1448 if (attr
->procedure
)
1450 duplicate_attr ("PROCEDURE", where
);
1454 attr
->procedure
= 1;
1456 return check_conflict (attr
, NULL
, where
);
1461 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1465 duplicate_attr ("ABSTRACT", where
);
1471 return check_conflict (attr
, NULL
, where
);
1475 /* Flavors are special because some flavors are not what Fortran
1476 considers attributes and can be reaffirmed multiple times. */
1479 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1483 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1484 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1485 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1488 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1491 if (attr
->flavor
!= FL_UNKNOWN
)
1494 where
= &gfc_current_locus
;
1497 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1498 gfc_code2string (flavors
, attr
->flavor
), name
,
1499 gfc_code2string (flavors
, f
), where
);
1501 gfc_error ("%s attribute conflicts with %s attribute at %L",
1502 gfc_code2string (flavors
, attr
->flavor
),
1503 gfc_code2string (flavors
, f
), where
);
1510 return check_conflict (attr
, name
, where
);
1515 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1516 const char *name
, locus
*where
)
1519 if (check_used (attr
, name
, where
))
1522 if (attr
->flavor
!= FL_PROCEDURE
1523 && !gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
))
1527 where
= &gfc_current_locus
;
1529 if (attr
->proc
!= PROC_UNKNOWN
)
1531 gfc_error ("%s procedure at %L is already declared as %s procedure",
1532 gfc_code2string (procedures
, t
), where
,
1533 gfc_code2string (procedures
, attr
->proc
));
1540 /* Statement functions are always scalar and functions. */
1541 if (t
== PROC_ST_FUNCTION
1542 && ((!attr
->function
&& !gfc_add_function (attr
, name
, where
))
1543 || attr
->dimension
))
1546 return check_conflict (attr
, name
, where
);
1551 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1554 if (check_used (attr
, NULL
, where
))
1557 if (attr
->intent
== INTENT_UNKNOWN
)
1559 attr
->intent
= intent
;
1560 return check_conflict (attr
, NULL
, where
);
1564 where
= &gfc_current_locus
;
1566 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1567 gfc_intent_string (attr
->intent
),
1568 gfc_intent_string (intent
), where
);
1574 /* No checks for use-association in public and private statements. */
1577 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1578 const char *name
, locus
*where
)
1581 if (attr
->access
== ACCESS_UNKNOWN
1582 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1584 attr
->access
= access
;
1585 return check_conflict (attr
, name
, where
);
1589 where
= &gfc_current_locus
;
1590 gfc_error ("ACCESS specification at %L was already specified", where
);
1596 /* Set the is_bind_c field for the given symbol_attribute. */
1599 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1600 int is_proc_lang_bind_spec
)
1603 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1604 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1605 "variables or common blocks", where
);
1606 else if (attr
->is_bind_c
)
1607 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1609 attr
->is_bind_c
= 1;
1612 where
= &gfc_current_locus
;
1614 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) at %L", where
))
1617 return check_conflict (attr
, name
, where
);
1621 /* Set the extension field for the given symbol_attribute. */
1624 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1627 where
= &gfc_current_locus
;
1629 if (attr
->extension
)
1630 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1632 attr
->extension
= 1;
1634 if (!gfc_notify_std (GFC_STD_F2003
, "EXTENDS at %L", where
))
1642 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1643 gfc_formal_arglist
* formal
, locus
*where
)
1646 if (check_used (&sym
->attr
, sym
->name
, where
))
1650 where
= &gfc_current_locus
;
1652 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1653 && sym
->attr
.if_source
!= IFSRC_DECL
)
1655 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1660 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1662 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1663 "body", sym
->name
, where
);
1667 sym
->formal
= formal
;
1668 sym
->attr
.if_source
= source
;
1674 /* Add a type to a symbol. */
1677 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1683 where
= &gfc_current_locus
;
1686 type
= sym
->result
->ts
.type
;
1688 type
= sym
->ts
.type
;
1690 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1691 type
= sym
->ns
->proc_name
->ts
.type
;
1693 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1695 if (sym
->attr
.use_assoc
)
1696 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1697 "use-associated at %L", sym
->name
, where
, sym
->module
,
1700 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1701 where
, gfc_basic_typename (type
));
1705 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1707 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1708 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1712 flavor
= sym
->attr
.flavor
;
1714 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1715 || flavor
== FL_LABEL
1716 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1717 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1719 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1728 /* Clears all attributes. */
1731 gfc_clear_attr (symbol_attribute
*attr
)
1733 memset (attr
, 0, sizeof (symbol_attribute
));
1737 /* Check for missing attributes in the new symbol. Currently does
1738 nothing, but it's not clear that it is unnecessary yet. */
1741 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1742 locus
*where ATTRIBUTE_UNUSED
)
1749 /* Copy an attribute to a symbol attribute, bit by bit. Some
1750 attributes have a lot of side-effects but cannot be present given
1751 where we are called from, so we ignore some bits. */
1754 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1756 int is_proc_lang_bind_spec
;
1758 /* In line with the other attributes, we only add bits but do not remove
1759 them; cf. also PR 41034. */
1760 dest
->ext_attr
|= src
->ext_attr
;
1762 if (src
->allocatable
&& !gfc_add_allocatable (dest
, where
))
1765 if (src
->dimension
&& !gfc_add_dimension (dest
, NULL
, where
))
1767 if (src
->codimension
&& !gfc_add_codimension (dest
, NULL
, where
))
1769 if (src
->contiguous
&& !gfc_add_contiguous (dest
, NULL
, where
))
1771 if (src
->optional
&& !gfc_add_optional (dest
, where
))
1773 if (src
->pointer
&& !gfc_add_pointer (dest
, where
))
1775 if (src
->is_protected
&& !gfc_add_protected (dest
, NULL
, where
))
1777 if (src
->save
&& !gfc_add_save (dest
, src
->save
, NULL
, where
))
1779 if (src
->value
&& !gfc_add_value (dest
, NULL
, where
))
1781 if (src
->volatile_
&& !gfc_add_volatile (dest
, NULL
, where
))
1783 if (src
->asynchronous
&& !gfc_add_asynchronous (dest
, NULL
, where
))
1785 if (src
->threadprivate
1786 && !gfc_add_threadprivate (dest
, NULL
, where
))
1788 if (src
->omp_declare_target
1789 && !gfc_add_omp_declare_target (dest
, NULL
, where
))
1791 if (src
->target
&& !gfc_add_target (dest
, where
))
1793 if (src
->dummy
&& !gfc_add_dummy (dest
, NULL
, where
))
1795 if (src
->result
&& !gfc_add_result (dest
, NULL
, where
))
1800 if (src
->in_namelist
&& !gfc_add_in_namelist (dest
, NULL
, where
))
1803 if (src
->in_common
&& !gfc_add_in_common (dest
, NULL
, where
))
1806 if (src
->generic
&& !gfc_add_generic (dest
, NULL
, where
))
1808 if (src
->function
&& !gfc_add_function (dest
, NULL
, where
))
1810 if (src
->subroutine
&& !gfc_add_subroutine (dest
, NULL
, where
))
1813 if (src
->sequence
&& !gfc_add_sequence (dest
, NULL
, where
))
1815 if (src
->elemental
&& !gfc_add_elemental (dest
, where
))
1817 if (src
->pure
&& !gfc_add_pure (dest
, where
))
1819 if (src
->recursive
&& !gfc_add_recursive (dest
, where
))
1822 if (src
->flavor
!= FL_UNKNOWN
1823 && !gfc_add_flavor (dest
, src
->flavor
, NULL
, where
))
1826 if (src
->intent
!= INTENT_UNKNOWN
1827 && !gfc_add_intent (dest
, src
->intent
, where
))
1830 if (src
->access
!= ACCESS_UNKNOWN
1831 && !gfc_add_access (dest
, src
->access
, NULL
, where
))
1834 if (!gfc_missing_attr (dest
, where
))
1837 if (src
->cray_pointer
&& !gfc_add_cray_pointer (dest
, where
))
1839 if (src
->cray_pointee
&& !gfc_add_cray_pointee (dest
, where
))
1842 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1844 && !gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
))
1847 if (src
->is_c_interop
)
1848 dest
->is_c_interop
= 1;
1852 if (src
->external
&& !gfc_add_external (dest
, where
))
1854 if (src
->intrinsic
&& !gfc_add_intrinsic (dest
, where
))
1856 if (src
->proc_pointer
)
1857 dest
->proc_pointer
= 1;
1866 /************** Component name management ************/
1868 /* Component names of a derived type form their own little namespaces
1869 that are separate from all other spaces. The space is composed of
1870 a singly linked list of gfc_component structures whose head is
1871 located in the parent symbol. */
1874 /* Add a component name to a symbol. The call fails if the name is
1875 already present. On success, the component pointer is modified to
1876 point to the additional component structure. */
1879 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1880 gfc_component
**component
)
1882 gfc_component
*p
, *tail
;
1886 for (p
= sym
->components
; p
; p
= p
->next
)
1888 if (strcmp (p
->name
, name
) == 0)
1890 gfc_error ("Component '%s' at %C already declared at %L",
1898 if (sym
->attr
.extension
1899 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1901 gfc_error ("Component '%s' at %C already in the parent type "
1902 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1906 /* Allocate a new component. */
1907 p
= gfc_get_component ();
1910 sym
->components
= p
;
1914 p
->name
= gfc_get_string (name
);
1915 p
->loc
= gfc_current_locus
;
1916 p
->ts
.type
= BT_UNKNOWN
;
1923 /* Recursive function to switch derived types of all symbol in a
1927 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1935 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1936 sym
->ts
.u
.derived
= to
;
1938 switch_types (st
->left
, from
, to
);
1939 switch_types (st
->right
, from
, to
);
1943 /* This subroutine is called when a derived type is used in order to
1944 make the final determination about which version to use. The
1945 standard requires that a type be defined before it is 'used', but
1946 such types can appear in IMPLICIT statements before the actual
1947 definition. 'Using' in this context means declaring a variable to
1948 be that type or using the type constructor.
1950 If a type is used and the components haven't been defined, then we
1951 have to have a derived type in a parent unit. We find the node in
1952 the other namespace and point the symtree node in this namespace to
1953 that node. Further reference to this name point to the correct
1954 node. If we can't find the node in a parent namespace, then we have
1957 This subroutine takes a pointer to a symbol node and returns a
1958 pointer to the translated node or NULL for an error. Usually there
1959 is no translation and we return the node we were passed. */
1962 gfc_use_derived (gfc_symbol
*sym
)
1972 if (sym
->attr
.unlimited_polymorphic
)
1975 if (sym
->attr
.generic
)
1976 sym
= gfc_find_dt_in_generic (sym
);
1978 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1979 return sym
; /* Already defined. */
1981 if (sym
->ns
->parent
== NULL
)
1984 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1986 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1990 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1993 /* Get rid of symbol sym, translating all references to s. */
1994 for (i
= 0; i
< GFC_LETTERS
; i
++)
1996 t
= &sym
->ns
->default_type
[i
];
1997 if (t
->u
.derived
== sym
)
2001 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2006 /* Unlink from list of modified symbols. */
2007 gfc_commit_symbol (sym
);
2009 switch_types (sym
->ns
->sym_root
, sym
, s
);
2011 /* TODO: Also have to replace sym -> s in other lists like
2012 namelists, common lists and interface lists. */
2013 gfc_free_symbol (sym
);
2018 gfc_error ("Derived type '%s' at %C is being used before it is defined",
2024 /* Given a derived type node and a component name, try to locate the
2025 component structure. Returns the NULL pointer if the component is
2026 not found or the components are private. If noaccess is set, no access
2030 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2031 bool noaccess
, bool silent
)
2035 if (name
== NULL
|| sym
== NULL
)
2038 sym
= gfc_use_derived (sym
);
2043 for (p
= sym
->components
; p
; p
= p
->next
)
2044 if (strcmp (p
->name
, name
) == 0)
2047 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2049 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2050 if (p
->attr
.access
== ACCESS_PRIVATE
||
2051 (p
->attr
.access
!= ACCESS_PUBLIC
2052 && sym
->component_access
== ACCESS_PRIVATE
2053 && !is_parent_comp
))
2056 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2063 && sym
->attr
.extension
2064 && sym
->components
->ts
.type
== BT_DERIVED
)
2066 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2068 /* Do not overwrite the error. */
2073 if (p
== NULL
&& !silent
)
2074 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2081 /* Given a symbol, free all of the component structures and everything
2085 free_components (gfc_component
*p
)
2093 gfc_free_array_spec (p
->as
);
2094 gfc_free_expr (p
->initializer
);
2102 /******************** Statement label management ********************/
2104 /* Comparison function for statement labels, used for managing the
2108 compare_st_labels (void *a1
, void *b1
)
2110 int a
= ((gfc_st_label
*) a1
)->value
;
2111 int b
= ((gfc_st_label
*) b1
)->value
;
2117 /* Free a single gfc_st_label structure, making sure the tree is not
2118 messed up. This function is called only when some parse error
2122 gfc_free_st_label (gfc_st_label
*label
)
2128 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2130 if (label
->format
!= NULL
)
2131 gfc_free_expr (label
->format
);
2137 /* Free a whole tree of gfc_st_label structures. */
2140 free_st_labels (gfc_st_label
*label
)
2146 free_st_labels (label
->left
);
2147 free_st_labels (label
->right
);
2149 if (label
->format
!= NULL
)
2150 gfc_free_expr (label
->format
);
2155 /* Given a label number, search for and return a pointer to the label
2156 structure, creating it if it does not exist. */
2159 gfc_get_st_label (int labelno
)
2164 if (gfc_current_state () == COMP_DERIVED
)
2165 ns
= gfc_current_block ()->f2k_derived
;
2168 /* Find the namespace of the scoping unit:
2169 If we're in a BLOCK construct, jump to the parent namespace. */
2170 ns
= gfc_current_ns
;
2171 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2175 /* First see if the label is already in this namespace. */
2179 if (lp
->value
== labelno
)
2182 if (lp
->value
< labelno
)
2188 lp
= XCNEW (gfc_st_label
);
2190 lp
->value
= labelno
;
2191 lp
->defined
= ST_LABEL_UNKNOWN
;
2192 lp
->referenced
= ST_LABEL_UNKNOWN
;
2194 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2200 /* Called when a statement with a statement label is about to be
2201 accepted. We add the label to the list of the current namespace,
2202 making sure it hasn't been defined previously and referenced
2206 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2210 labelno
= lp
->value
;
2212 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2213 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2214 &lp
->where
, label_locus
);
2217 lp
->where
= *label_locus
;
2221 case ST_LABEL_FORMAT
:
2222 if (lp
->referenced
== ST_LABEL_TARGET
2223 || lp
->referenced
== ST_LABEL_DO_TARGET
)
2224 gfc_error ("Label %d at %C already referenced as branch target",
2227 lp
->defined
= ST_LABEL_FORMAT
;
2231 case ST_LABEL_TARGET
:
2232 case ST_LABEL_DO_TARGET
:
2233 if (lp
->referenced
== ST_LABEL_FORMAT
)
2234 gfc_error ("Label %d at %C already referenced as a format label",
2239 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
!= ST_LABEL_DO_TARGET
2240 && !gfc_notify_std (GFC_STD_F95_OBS
, "DO termination statement "
2241 "which is not END DO or CONTINUE with "
2242 "label %d at %C", labelno
))
2247 lp
->defined
= ST_LABEL_BAD_TARGET
;
2248 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2254 /* Reference a label. Given a label and its type, see if that
2255 reference is consistent with what is known about that label,
2256 updating the unknown state. Returns false if something goes
2260 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2262 gfc_sl_type label_type
;
2269 labelno
= lp
->value
;
2271 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2272 label_type
= lp
->defined
;
2275 label_type
= lp
->referenced
;
2276 lp
->where
= gfc_current_locus
;
2279 if (label_type
== ST_LABEL_FORMAT
2280 && (type
== ST_LABEL_TARGET
|| type
== ST_LABEL_DO_TARGET
))
2282 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2287 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_DO_TARGET
2288 || label_type
== ST_LABEL_BAD_TARGET
)
2289 && type
== ST_LABEL_FORMAT
)
2291 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2296 if (lp
->referenced
== ST_LABEL_DO_TARGET
&& type
== ST_LABEL_DO_TARGET
2297 && !gfc_notify_std (GFC_STD_F95_OBS
, "Shared DO termination label %d "
2301 if (lp
->referenced
!= ST_LABEL_DO_TARGET
)
2302 lp
->referenced
= type
;
2310 /************** Symbol table management subroutines ****************/
2312 /* Basic details: Fortran 95 requires a potentially unlimited number
2313 of distinct namespaces when compiling a program unit. This case
2314 occurs during a compilation of internal subprograms because all of
2315 the internal subprograms must be read before we can start
2316 generating code for the host.
2318 Given the tricky nature of the Fortran grammar, we must be able to
2319 undo changes made to a symbol table if the current interpretation
2320 of a statement is found to be incorrect. Whenever a symbol is
2321 looked up, we make a copy of it and link to it. All of these
2322 symbols are kept in a vector so that we can commit or
2323 undo the changes at a later time.
2325 A symtree may point to a symbol node outside of its namespace. In
2326 this case, that symbol has been used as a host associated variable
2327 at some previous time. */
2329 /* Allocate a new namespace structure. Copies the implicit types from
2330 PARENT if PARENT_TYPES is set. */
2333 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2340 ns
= XCNEW (gfc_namespace
);
2341 ns
->sym_root
= NULL
;
2342 ns
->uop_root
= NULL
;
2343 ns
->tb_sym_root
= NULL
;
2344 ns
->finalizers
= NULL
;
2345 ns
->default_access
= ACCESS_UNKNOWN
;
2346 ns
->parent
= parent
;
2348 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2350 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2351 ns
->tb_op
[in
] = NULL
;
2354 /* Initialize default implicit types. */
2355 for (i
= 'a'; i
<= 'z'; i
++)
2357 ns
->set_flag
[i
- 'a'] = 0;
2358 ts
= &ns
->default_type
[i
- 'a'];
2360 if (parent_types
&& ns
->parent
!= NULL
)
2362 /* Copy parent settings. */
2363 *ts
= ns
->parent
->default_type
[i
- 'a'];
2367 if (gfc_option
.flag_implicit_none
!= 0)
2373 if ('i' <= i
&& i
<= 'n')
2375 ts
->type
= BT_INTEGER
;
2376 ts
->kind
= gfc_default_integer_kind
;
2381 ts
->kind
= gfc_default_real_kind
;
2391 /* Comparison function for symtree nodes. */
2394 compare_symtree (void *_st1
, void *_st2
)
2396 gfc_symtree
*st1
, *st2
;
2398 st1
= (gfc_symtree
*) _st1
;
2399 st2
= (gfc_symtree
*) _st2
;
2401 return strcmp (st1
->name
, st2
->name
);
2405 /* Allocate a new symtree node and associate it with the new symbol. */
2408 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2412 st
= XCNEW (gfc_symtree
);
2413 st
->name
= gfc_get_string (name
);
2415 gfc_insert_bbt (root
, st
, compare_symtree
);
2420 /* Delete a symbol from the tree. Does not free the symbol itself! */
2423 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2425 gfc_symtree st
, *st0
;
2427 st0
= gfc_find_symtree (*root
, name
);
2429 st
.name
= gfc_get_string (name
);
2430 gfc_delete_bbt (root
, &st
, compare_symtree
);
2436 /* Given a root symtree node and a name, try to find the symbol within
2437 the namespace. Returns NULL if the symbol is not found. */
2440 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2446 c
= strcmp (name
, st
->name
);
2450 st
= (c
< 0) ? st
->left
: st
->right
;
2457 /* Return a symtree node with a name that is guaranteed to be unique
2458 within the namespace and corresponds to an illegal fortran name. */
2461 gfc_get_unique_symtree (gfc_namespace
*ns
)
2463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2464 static int serial
= 0;
2466 sprintf (name
, "@%d", serial
++);
2467 return gfc_new_symtree (&ns
->sym_root
, name
);
2471 /* Given a name find a user operator node, creating it if it doesn't
2472 exist. These are much simpler than symbols because they can't be
2473 ambiguous with one another. */
2476 gfc_get_uop (const char *name
)
2480 gfc_namespace
*ns
= gfc_current_ns
;
2484 st
= gfc_find_symtree (ns
->uop_root
, name
);
2488 st
= gfc_new_symtree (&ns
->uop_root
, name
);
2490 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2491 uop
->name
= gfc_get_string (name
);
2492 uop
->access
= ACCESS_UNKNOWN
;
2499 /* Given a name find the user operator node. Returns NULL if it does
2503 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2508 ns
= gfc_current_ns
;
2510 st
= gfc_find_symtree (ns
->uop_root
, name
);
2511 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2515 /* Remove a gfc_symbol structure and everything it points to. */
2518 gfc_free_symbol (gfc_symbol
*sym
)
2524 gfc_free_array_spec (sym
->as
);
2526 free_components (sym
->components
);
2528 gfc_free_expr (sym
->value
);
2530 gfc_free_namelist (sym
->namelist
);
2532 if (sym
->ns
!= sym
->formal_ns
)
2533 gfc_free_namespace (sym
->formal_ns
);
2535 if (!sym
->attr
.generic_copy
)
2536 gfc_free_interface (sym
->generic
);
2538 gfc_free_formal_arglist (sym
->formal
);
2540 gfc_free_namespace (sym
->f2k_derived
);
2542 if (sym
->common_block
&& sym
->common_block
->name
[0] != '\0')
2544 sym
->common_block
->refs
--;
2545 if (sym
->common_block
->refs
== 0)
2546 free (sym
->common_block
);
2553 /* Decrease the reference counter and free memory when we reach zero. */
2556 gfc_release_symbol (gfc_symbol
*sym
)
2561 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2 && sym
->formal_ns
!= sym
->ns
2562 && (!sym
->attr
.entry
|| !sym
->module
))
2564 /* As formal_ns contains a reference to sym, delete formal_ns just
2565 before the deletion of sym. */
2566 gfc_namespace
*ns
= sym
->formal_ns
;
2567 sym
->formal_ns
= NULL
;
2568 gfc_free_namespace (ns
);
2575 gcc_assert (sym
->refs
== 0);
2576 gfc_free_symbol (sym
);
2580 /* Allocate and initialize a new symbol node. */
2583 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2587 p
= XCNEW (gfc_symbol
);
2589 gfc_clear_ts (&p
->ts
);
2590 gfc_clear_attr (&p
->attr
);
2593 p
->declared_at
= gfc_current_locus
;
2595 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2596 gfc_internal_error ("new_symbol(): Symbol name too long");
2598 p
->name
= gfc_get_string (name
);
2600 /* Make sure flags for symbol being C bound are clear initially. */
2601 p
->attr
.is_bind_c
= 0;
2602 p
->attr
.is_iso_c
= 0;
2604 /* Clear the ptrs we may need. */
2605 p
->common_block
= NULL
;
2606 p
->f2k_derived
= NULL
;
2613 /* Generate an error if a symbol is ambiguous. */
2616 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2619 if (st
->n
.sym
->module
)
2620 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2621 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2623 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2624 "from current program unit", name
, st
->n
.sym
->name
);
2628 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2629 selector on the stack. If yes, replace it by the corresponding temporary. */
2632 select_type_insert_tmp (gfc_symtree
**st
)
2634 gfc_select_type_stack
*stack
= select_type_stack
;
2635 for (; stack
; stack
= stack
->prev
)
2636 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2641 /* Look for a symtree in the current procedure -- that is, go up to
2642 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2645 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
2649 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
2653 if (!ns
->construct_entities
)
2662 /* Search for a symtree starting in the current namespace, resorting to
2663 any parent namespaces if requested by a nonzero parent_flag.
2664 Returns nonzero if the name is ambiguous. */
2667 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2668 gfc_symtree
**result
)
2673 ns
= gfc_current_ns
;
2677 st
= gfc_find_symtree (ns
->sym_root
, name
);
2680 select_type_insert_tmp (&st
);
2683 /* Ambiguous generic interfaces are permitted, as long
2684 as the specific interfaces are different. */
2685 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2687 ambiguous_symbol (name
, st
);
2697 /* Don't escape an interface block. */
2698 if (ns
&& !ns
->has_import_set
2699 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
2711 /* Same, but returns the symbol instead. */
2714 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2715 gfc_symbol
**result
)
2720 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2725 *result
= st
->n
.sym
;
2731 /* Tells whether there is only one set of changes in the stack. */
2734 single_undo_checkpoint_p (void)
2736 if (latest_undo_chgset
== &default_undo_chgset_var
)
2738 gcc_assert (latest_undo_chgset
->previous
== NULL
);
2743 gcc_assert (latest_undo_chgset
->previous
!= NULL
);
2748 /* Save symbol with the information necessary to back it out. */
2751 gfc_save_symbol_data (gfc_symbol
*sym
)
2756 if (!single_undo_checkpoint_p ())
2758 /* If there is more than one change set, look for the symbol in the
2759 current one. If it is found there, we can reuse it. */
2760 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
2763 gcc_assert (sym
->gfc_new
|| sym
->old_symbol
!= NULL
);
2767 else if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2770 s
= XCNEW (gfc_symbol
);
2772 sym
->old_symbol
= s
;
2775 latest_undo_chgset
->syms
.safe_push (sym
);
2779 /* Given a name, find a symbol, or create it if it does not exist yet
2780 in the current namespace. If the symbol is found we make sure that
2783 The integer return code indicates
2785 1 The symbol name was ambiguous
2786 2 The name meant to be established was already host associated.
2788 So if the return value is nonzero, then an error was issued. */
2791 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2792 bool allow_subroutine
)
2797 /* This doesn't usually happen during resolution. */
2799 ns
= gfc_current_ns
;
2801 /* Try to find the symbol in ns. */
2802 st
= gfc_find_symtree (ns
->sym_root
, name
);
2804 if (st
== NULL
&& ns
->omp_udr_ns
)
2807 st
= gfc_find_symtree (ns
->sym_root
, name
);
2812 /* If not there, create a new symbol. */
2813 p
= gfc_new_symbol (name
, ns
);
2815 /* Add to the list of tentative symbols. */
2816 p
->old_symbol
= NULL
;
2819 latest_undo_chgset
->syms
.safe_push (p
);
2821 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2828 /* Make sure the existing symbol is OK. Ambiguous
2829 generic interfaces are permitted, as long as the
2830 specific interfaces are different. */
2831 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2833 ambiguous_symbol (name
, st
);
2838 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2839 && !(allow_subroutine
&& p
->attr
.subroutine
)
2840 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2841 && (ns
->has_import_set
|| p
->attr
.imported
)))
2843 /* Symbol is from another namespace. */
2844 gfc_error ("Symbol '%s' at %C has already been host associated",
2851 /* Copy in case this symbol is changed. */
2852 gfc_save_symbol_data (p
);
2861 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2866 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2871 *result
= st
->n
.sym
;
2878 /* Subroutine that searches for a symbol, creating it if it doesn't
2879 exist, but tries to host-associate the symbol if possible. */
2882 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2887 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2891 gfc_save_symbol_data (st
->n
.sym
);
2896 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 1, &st
);
2906 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2911 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2916 i
= gfc_get_ha_sym_tree (name
, &st
);
2919 *result
= st
->n
.sym
;
2927 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2928 head->name as the common_root symtree's name might be mangled. */
2930 static gfc_symtree
*
2931 find_common_symtree (gfc_symtree
*st
, gfc_common_head
*head
)
2934 gfc_symtree
*result
;
2939 if (st
->n
.common
== head
)
2942 result
= find_common_symtree (st
->left
, head
);
2944 result
= find_common_symtree (st
->right
, head
);
2950 /* Clear the given storage, and make it the current change set for registering
2951 changed symbols. Its contents are freed after a call to
2952 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
2953 it is up to the caller to free the storage itself. It is usually a local
2954 variable, so there is nothing to do anyway. */
2957 gfc_new_undo_checkpoint (gfc_undo_change_set
&chg_syms
)
2959 chg_syms
.syms
= vNULL
;
2960 chg_syms
.tbps
= vNULL
;
2961 chg_syms
.previous
= latest_undo_chgset
;
2962 latest_undo_chgset
= &chg_syms
;
2966 /* Restore previous state of symbol. Just copy simple stuff. */
2969 restore_old_symbol (gfc_symbol
*p
)
2974 old
= p
->old_symbol
;
2976 p
->ts
.type
= old
->ts
.type
;
2977 p
->ts
.kind
= old
->ts
.kind
;
2979 p
->attr
= old
->attr
;
2981 if (p
->value
!= old
->value
)
2983 gcc_checking_assert (old
->value
== NULL
);
2984 gfc_free_expr (p
->value
);
2988 if (p
->as
!= old
->as
)
2991 gfc_free_array_spec (p
->as
);
2995 p
->generic
= old
->generic
;
2996 p
->component_access
= old
->component_access
;
2998 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
3000 gfc_free_namelist (p
->namelist
);
3005 if (p
->namelist_tail
!= old
->namelist_tail
)
3007 gfc_free_namelist (old
->namelist_tail
->next
);
3008 old
->namelist_tail
->next
= NULL
;
3012 p
->namelist_tail
= old
->namelist_tail
;
3014 if (p
->formal
!= old
->formal
)
3016 gfc_free_formal_arglist (p
->formal
);
3017 p
->formal
= old
->formal
;
3020 p
->old_symbol
= old
->old_symbol
;
3025 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3026 the structure itself. */
3029 free_undo_change_set_data (gfc_undo_change_set
&cs
)
3036 /* Given a change set pointer, free its target's contents and update it with
3037 the address of the previous change set. Note that only the contents are
3038 freed, not the target itself (the contents' container). It is not a problem
3039 as the latter will be a local variable usually. */
3042 pop_undo_change_set (gfc_undo_change_set
*&cs
)
3044 free_undo_change_set_data (*cs
);
3049 static void free_old_symbol (gfc_symbol
*sym
);
3052 /* Merges the current change set into the previous one. The changes themselves
3053 are left untouched; only one checkpoint is forgotten. */
3056 gfc_drop_last_undo_checkpoint (void)
3061 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, s
)
3063 /* No need to loop in this case. */
3064 if (s
->old_symbol
== NULL
)
3067 /* Remove the duplicate symbols. */
3068 FOR_EACH_VEC_ELT (latest_undo_chgset
->previous
->syms
, j
, t
)
3071 latest_undo_chgset
->previous
->syms
.unordered_remove (j
);
3073 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3074 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3075 shall contain from now on the backup symbol for S as it was
3076 at the checkpoint before. */
3077 if (s
->old_symbol
->gfc_new
)
3079 gcc_assert (s
->old_symbol
->old_symbol
== NULL
);
3080 s
->gfc_new
= s
->old_symbol
->gfc_new
;
3081 free_old_symbol (s
);
3084 restore_old_symbol (s
->old_symbol
);
3089 latest_undo_chgset
->previous
->syms
.safe_splice (latest_undo_chgset
->syms
);
3090 latest_undo_chgset
->previous
->tbps
.safe_splice (latest_undo_chgset
->tbps
);
3092 pop_undo_change_set (latest_undo_chgset
);
3096 /* Undoes all the changes made to symbols since the previous checkpoint.
3097 This subroutine is made simpler due to the fact that attributes are
3098 never removed once added. */
3101 gfc_restore_last_undo_checkpoint (void)
3106 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3110 /* Symbol was new. */
3111 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
3113 /* If the symbol was added to any common block, it
3114 needs to be removed to stop the resolver looking
3115 for a (possibly) dead symbol. */
3117 if (p
->common_block
->head
== p
&& !p
->common_next
)
3119 gfc_symtree st
, *st0
;
3120 st0
= find_common_symtree (p
->ns
->common_root
,
3124 st
.name
= st0
->name
;
3125 gfc_delete_bbt (&p
->ns
->common_root
, &st
, compare_symtree
);
3130 if (p
->common_block
->head
== p
)
3131 p
->common_block
->head
= p
->common_next
;
3134 gfc_symbol
*cparent
, *csym
;
3136 cparent
= p
->common_block
->head
;
3137 csym
= cparent
->common_next
;
3142 csym
= csym
->common_next
;
3145 gcc_assert(cparent
->common_next
== p
);
3147 cparent
->common_next
= csym
->common_next
;
3151 /* The derived type is saved in the symtree with the first
3152 letter capitalized; the all lower-case version to the
3153 derived type contains its associated generic function. */
3154 if (p
->attr
.flavor
== FL_DERIVED
)
3155 gfc_delete_symtree (&p
->ns
->sym_root
, gfc_get_string ("%c%s",
3156 (char) TOUPPER ((unsigned char) p
->name
[0]),
3159 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
3161 gfc_release_symbol (p
);
3164 restore_old_symbol (p
);
3167 latest_undo_chgset
->syms
.truncate (0);
3168 latest_undo_chgset
->tbps
.truncate (0);
3170 if (!single_undo_checkpoint_p ())
3171 pop_undo_change_set (latest_undo_chgset
);
3175 /* Makes sure that there is only one set of changes; in other words we haven't
3176 forgotten to pair a call to gfc_new_checkpoint with a call to either
3177 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3180 enforce_single_undo_checkpoint (void)
3182 gcc_checking_assert (single_undo_checkpoint_p ());
3186 /* Undoes all the changes made to symbols in the current statement. */
3189 gfc_undo_symbols (void)
3191 enforce_single_undo_checkpoint ();
3192 gfc_restore_last_undo_checkpoint ();
3196 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3197 components of old_symbol that might need deallocation are the "allocatables"
3198 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3199 namelist_tail. In case these differ between old_symbol and sym, it's just
3200 because sym->namelist has gotten a few more items. */
3203 free_old_symbol (gfc_symbol
*sym
)
3206 if (sym
->old_symbol
== NULL
)
3209 if (sym
->old_symbol
->as
!= sym
->as
)
3210 gfc_free_array_spec (sym
->old_symbol
->as
);
3212 if (sym
->old_symbol
->value
!= sym
->value
)
3213 gfc_free_expr (sym
->old_symbol
->value
);
3215 if (sym
->old_symbol
->formal
!= sym
->formal
)
3216 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
3218 free (sym
->old_symbol
);
3219 sym
->old_symbol
= NULL
;
3223 /* Makes the changes made in the current statement permanent-- gets
3224 rid of undo information. */
3227 gfc_commit_symbols (void)
3230 gfc_typebound_proc
*tbp
;
3233 enforce_single_undo_checkpoint ();
3235 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3239 free_old_symbol (p
);
3241 latest_undo_chgset
->syms
.truncate (0);
3243 FOR_EACH_VEC_ELT (latest_undo_chgset
->tbps
, i
, tbp
)
3245 latest_undo_chgset
->tbps
.truncate (0);
3249 /* Makes the changes made in one symbol permanent -- gets rid of undo
3253 gfc_commit_symbol (gfc_symbol
*sym
)
3258 enforce_single_undo_checkpoint ();
3260 FOR_EACH_VEC_ELT (latest_undo_chgset
->syms
, i
, p
)
3263 latest_undo_chgset
->syms
.unordered_remove (i
);
3270 free_old_symbol (sym
);
3274 /* Recursively free trees containing type-bound procedures. */
3277 free_tb_tree (gfc_symtree
*t
)
3282 free_tb_tree (t
->left
);
3283 free_tb_tree (t
->right
);
3285 /* TODO: Free type-bound procedure structs themselves; probably needs some
3286 sort of ref-counting mechanism. */
3292 /* Recursive function that deletes an entire tree and all the common
3293 head structures it points to. */
3296 free_common_tree (gfc_symtree
* common_tree
)
3298 if (common_tree
== NULL
)
3301 free_common_tree (common_tree
->left
);
3302 free_common_tree (common_tree
->right
);
3308 /* Recursive function that deletes an entire tree and all the common
3309 head structures it points to. */
3312 free_omp_udr_tree (gfc_symtree
* omp_udr_tree
)
3314 if (omp_udr_tree
== NULL
)
3317 free_omp_udr_tree (omp_udr_tree
->left
);
3318 free_omp_udr_tree (omp_udr_tree
->right
);
3320 gfc_free_omp_udr (omp_udr_tree
->n
.omp_udr
);
3321 free (omp_udr_tree
);
3325 /* Recursive function that deletes an entire tree and all the user
3326 operator nodes that it contains. */
3329 free_uop_tree (gfc_symtree
*uop_tree
)
3331 if (uop_tree
== NULL
)
3334 free_uop_tree (uop_tree
->left
);
3335 free_uop_tree (uop_tree
->right
);
3337 gfc_free_interface (uop_tree
->n
.uop
->op
);
3338 free (uop_tree
->n
.uop
);
3343 /* Recursive function that deletes an entire tree and all the symbols
3344 that it contains. */
3347 free_sym_tree (gfc_symtree
*sym_tree
)
3349 if (sym_tree
== NULL
)
3352 free_sym_tree (sym_tree
->left
);
3353 free_sym_tree (sym_tree
->right
);
3355 gfc_release_symbol (sym_tree
->n
.sym
);
3360 /* Free the derived type list. */
3363 gfc_free_dt_list (void)
3365 gfc_dt_list
*dt
, *n
;
3367 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3373 gfc_derived_types
= NULL
;
3377 /* Free the gfc_equiv_info's. */
3380 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3384 gfc_free_equiv_infos (s
->next
);
3389 /* Free the gfc_equiv_lists. */
3392 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3396 gfc_free_equiv_lists (l
->next
);
3397 gfc_free_equiv_infos (l
->equiv
);
3402 /* Free a finalizer procedure list. */
3405 gfc_free_finalizer (gfc_finalizer
* el
)
3409 gfc_release_symbol (el
->proc_sym
);
3415 gfc_free_finalizer_list (gfc_finalizer
* list
)
3419 gfc_finalizer
* current
= list
;
3421 gfc_free_finalizer (current
);
3426 /* Create a new gfc_charlen structure and add it to a namespace.
3427 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3430 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3433 cl
= gfc_get_charlen ();
3438 /* Put into namespace, but don't allow reject_statement
3439 to free it if old_cl is given. */
3440 gfc_charlen
**prev
= &ns
->cl_list
;
3441 cl
->next
= ns
->old_cl_list
;
3442 while (*prev
!= ns
->old_cl_list
)
3443 prev
= &(*prev
)->next
;
3445 ns
->old_cl_list
= cl
;
3446 cl
->length
= gfc_copy_expr (old_cl
->length
);
3447 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3448 cl
->backend_decl
= old_cl
->backend_decl
;
3449 cl
->passed_length
= old_cl
->passed_length
;
3450 cl
->resolved
= old_cl
->resolved
;
3454 /* Put into namespace. */
3455 cl
->next
= ns
->cl_list
;
3463 /* Free the charlen list from cl to end (end is not freed).
3464 Free the whole list if end is NULL. */
3467 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3471 for (; cl
!= end
; cl
= cl2
)
3476 gfc_free_expr (cl
->length
);
3482 /* Free entry list structs. */
3485 free_entry_list (gfc_entry_list
*el
)
3487 gfc_entry_list
*next
;
3494 free_entry_list (next
);
3498 /* Free a namespace structure and everything below it. Interface
3499 lists associated with intrinsic operators are not freed. These are
3500 taken care of when a specific name is freed. */
3503 gfc_free_namespace (gfc_namespace
*ns
)
3505 gfc_namespace
*p
, *q
;
3514 gcc_assert (ns
->refs
== 0);
3516 gfc_free_statements (ns
->code
);
3518 free_sym_tree (ns
->sym_root
);
3519 free_uop_tree (ns
->uop_root
);
3520 free_common_tree (ns
->common_root
);
3521 free_omp_udr_tree (ns
->omp_udr_root
);
3522 free_tb_tree (ns
->tb_sym_root
);
3523 free_tb_tree (ns
->tb_uop_root
);
3524 gfc_free_finalizer_list (ns
->finalizers
);
3525 gfc_free_omp_declare_simd_list (ns
->omp_declare_simd
);
3526 gfc_free_charlen (ns
->cl_list
, NULL
);
3527 free_st_labels (ns
->st_labels
);
3529 free_entry_list (ns
->entries
);
3530 gfc_free_equiv (ns
->equiv
);
3531 gfc_free_equiv_lists (ns
->equiv_lists
);
3532 gfc_free_use_stmts (ns
->use_stmts
);
3534 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3535 gfc_free_interface (ns
->op
[i
]);
3537 gfc_free_data (ns
->data
);
3541 /* Recursively free any contained namespaces. */
3546 gfc_free_namespace (q
);
3552 gfc_symbol_init_2 (void)
3555 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3560 gfc_symbol_done_2 (void)
3562 gfc_free_namespace (gfc_current_ns
);
3563 gfc_current_ns
= NULL
;
3564 gfc_free_dt_list ();
3566 enforce_single_undo_checkpoint ();
3567 free_undo_change_set_data (*latest_undo_chgset
);
3571 /* Count how many nodes a symtree has. */
3574 count_st_nodes (const gfc_symtree
*st
)
3580 nodes
= count_st_nodes (st
->left
);
3582 nodes
+= count_st_nodes (st
->right
);
3588 /* Convert symtree tree into symtree vector. */
3591 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
3596 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
3597 st_vec
[node_cntr
++] = st
;
3598 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
3604 /* Traverse namespace. As the functions might modify the symtree, we store the
3605 symtree as a vector and operate on this vector. Note: We assume that
3606 sym_func or st_func never deletes nodes from the symtree - only adding is
3607 allowed. Additionally, newly added nodes are not traversed. */
3610 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
3611 void (*sym_func
) (gfc_symbol
*))
3613 gfc_symtree
**st_vec
;
3614 unsigned nodes
, i
, node_cntr
;
3616 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
3617 nodes
= count_st_nodes (st
);
3618 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
3620 fill_st_vector (st
, st_vec
, node_cntr
);
3625 for (i
= 0; i
< nodes
; i
++)
3626 st_vec
[i
]->n
.sym
->mark
= 0;
3627 for (i
= 0; i
< nodes
; i
++)
3628 if (!st_vec
[i
]->n
.sym
->mark
)
3630 (*sym_func
) (st_vec
[i
]->n
.sym
);
3631 st_vec
[i
]->n
.sym
->mark
= 1;
3635 for (i
= 0; i
< nodes
; i
++)
3636 (*st_func
) (st_vec
[i
]);
3640 /* Recursively traverse the symtree nodes. */
3643 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
3645 do_traverse_symtree (st
, st_func
, NULL
);
3649 /* Call a given function for all symbols in the namespace. We take
3650 care that each gfc_symbol node is called exactly once. */
3653 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
3655 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
3659 /* Return TRUE when name is the name of an intrinsic type. */
3662 gfc_is_intrinsic_typename (const char *name
)
3664 if (strcmp (name
, "integer") == 0
3665 || strcmp (name
, "real") == 0
3666 || strcmp (name
, "character") == 0
3667 || strcmp (name
, "logical") == 0
3668 || strcmp (name
, "complex") == 0
3669 || strcmp (name
, "doubleprecision") == 0
3670 || strcmp (name
, "doublecomplex") == 0)
3677 /* Return TRUE if the symbol is an automatic variable. */
3680 gfc_is_var_automatic (gfc_symbol
*sym
)
3682 /* Pointer and allocatable variables are never automatic. */
3683 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3685 /* Check for arrays with non-constant size. */
3686 if (sym
->attr
.dimension
&& sym
->as
3687 && !gfc_is_compile_time_shape (sym
->as
))
3689 /* Check for non-constant length character variables. */
3690 if (sym
->ts
.type
== BT_CHARACTER
3692 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3697 /* Given a symbol, mark it as SAVEd if it is allowed. */
3700 save_symbol (gfc_symbol
*sym
)
3703 if (sym
->attr
.use_assoc
)
3706 if (sym
->attr
.in_common
3709 || sym
->attr
.flavor
!= FL_VARIABLE
)
3711 /* Automatic objects are not saved. */
3712 if (gfc_is_var_automatic (sym
))
3714 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
3718 /* Mark those symbols which can be SAVEd as such. */
3721 gfc_save_all (gfc_namespace
*ns
)
3723 gfc_traverse_ns (ns
, save_symbol
);
3727 /* Make sure that no changes to symbols are pending. */
3730 gfc_enforce_clean_symbol_state(void)
3732 enforce_single_undo_checkpoint ();
3733 gcc_assert (latest_undo_chgset
->syms
.is_empty ());
3737 /************** Global symbol handling ************/
3740 /* Search a tree for the global symbol. */
3743 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3752 c
= strcmp (name
, symbol
->name
);
3756 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3763 /* Compare two global symbols. Used for managing the BB tree. */
3766 gsym_compare (void *_s1
, void *_s2
)
3768 gfc_gsymbol
*s1
, *s2
;
3770 s1
= (gfc_gsymbol
*) _s1
;
3771 s2
= (gfc_gsymbol
*) _s2
;
3772 return strcmp (s1
->name
, s2
->name
);
3776 /* Get a global symbol, creating it if it doesn't exist. */
3779 gfc_get_gsymbol (const char *name
)
3783 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3787 s
= XCNEW (gfc_gsymbol
);
3788 s
->type
= GSYM_UNKNOWN
;
3789 s
->name
= gfc_get_string (name
);
3791 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3798 get_iso_c_binding_dt (int sym_id
)
3800 gfc_dt_list
*dt_list
;
3802 dt_list
= gfc_derived_types
;
3804 /* Loop through the derived types in the name list, searching for
3805 the desired symbol from iso_c_binding. Search the parent namespaces
3806 if necessary and requested to (parent_flag). */
3807 while (dt_list
!= NULL
)
3809 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3810 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3811 return dt_list
->derived
;
3813 dt_list
= dt_list
->next
;
3820 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3821 with C. This is necessary for any derived type that is BIND(C) and for
3822 derived types that are parameters to functions that are BIND(C). All
3823 fields of the derived type are required to be interoperable, and are tested
3824 for such. If an error occurs, the errors are reported here, allowing for
3825 multiple errors to be handled for a single derived type. */
3828 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3830 gfc_component
*curr_comp
= NULL
;
3831 bool is_c_interop
= false;
3834 if (derived_sym
== NULL
)
3835 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3836 "unexpectedly NULL");
3838 /* If we've already looked at this derived symbol, do not look at it again
3839 so we don't repeat warnings/errors. */
3840 if (derived_sym
->ts
.is_c_interop
)
3843 /* The derived type must have the BIND attribute to be interoperable
3844 J3/04-007, Section 15.2.3. */
3845 if (derived_sym
->attr
.is_bind_c
!= 1)
3847 derived_sym
->ts
.is_c_interop
= 0;
3848 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3849 "attribute to be C interoperable", derived_sym
->name
,
3850 &(derived_sym
->declared_at
));
3854 curr_comp
= derived_sym
->components
;
3856 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3857 empty struct. Section 15.2 in Fortran 2003 states: "The following
3858 subclauses define the conditions under which a Fortran entity is
3859 interoperable. If a Fortran entity is interoperable, an equivalent
3860 entity may be defined by means of C and the Fortran entity is said
3861 to be interoperable with the C entity. There does not have to be such
3862 an interoperating C entity."
3864 if (curr_comp
== NULL
)
3866 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3867 "and may be inaccessible by the C companion processor",
3868 derived_sym
->name
, &(derived_sym
->declared_at
));
3869 derived_sym
->ts
.is_c_interop
= 1;
3870 derived_sym
->attr
.is_bind_c
= 1;
3875 /* Initialize the derived type as being C interoperable.
3876 If we find an error in the components, this will be set false. */
3877 derived_sym
->ts
.is_c_interop
= 1;
3879 /* Loop through the list of components to verify that the kind of
3880 each is a C interoperable type. */
3883 /* The components cannot be pointers (fortran sense).
3884 J3/04-007, Section 15.2.3, C1505. */
3885 if (curr_comp
->attr
.pointer
!= 0)
3887 gfc_error ("Component '%s' at %L cannot have the "
3888 "POINTER attribute because it is a member "
3889 "of the BIND(C) derived type '%s' at %L",
3890 curr_comp
->name
, &(curr_comp
->loc
),
3891 derived_sym
->name
, &(derived_sym
->declared_at
));
3895 if (curr_comp
->attr
.proc_pointer
!= 0)
3897 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3898 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3899 &curr_comp
->loc
, derived_sym
->name
,
3900 &derived_sym
->declared_at
);
3904 /* The components cannot be allocatable.
3905 J3/04-007, Section 15.2.3, C1505. */
3906 if (curr_comp
->attr
.allocatable
!= 0)
3908 gfc_error ("Component '%s' at %L cannot have the "
3909 "ALLOCATABLE attribute because it is a member "
3910 "of the BIND(C) derived type '%s' at %L",
3911 curr_comp
->name
, &(curr_comp
->loc
),
3912 derived_sym
->name
, &(derived_sym
->declared_at
));
3916 /* BIND(C) derived types must have interoperable components. */
3917 if (curr_comp
->ts
.type
== BT_DERIVED
3918 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3919 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3921 /* This should be allowed; the draft says a derived-type can not
3922 have type parameters if it is has the BIND attribute. Type
3923 parameters seem to be for making parameterized derived types.
3924 There's no need to verify the type if it is c_ptr/c_funptr. */
3925 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3929 /* Grab the typespec for the given component and test the kind. */
3930 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
3934 /* Report warning and continue since not fatal. The
3935 draft does specify a constraint that requires all fields
3936 to interoperate, but if the user says real(4), etc., it
3937 may interoperate with *something* in C, but the compiler
3938 most likely won't know exactly what. Further, it may not
3939 interoperate with the same data type(s) in C if the user
3940 recompiles with different flags (e.g., -m32 and -m64 on
3941 x86_64 and using integer(4) to claim interop with a
3943 if (derived_sym
->attr
.is_bind_c
== 1
3944 && gfc_option
.warn_c_binding_type
)
3945 /* If the derived type is bind(c), all fields must be
3947 gfc_warning ("Component '%s' in derived type '%s' at %L "
3948 "may not be C interoperable, even though "
3949 "derived type '%s' is BIND(C)",
3950 curr_comp
->name
, derived_sym
->name
,
3951 &(curr_comp
->loc
), derived_sym
->name
);
3952 else if (gfc_option
.warn_c_binding_type
)
3953 /* If derived type is param to bind(c) routine, or to one
3954 of the iso_c_binding procs, it must be interoperable, so
3955 all fields must interop too. */
3956 gfc_warning ("Component '%s' in derived type '%s' at %L "
3957 "may not be C interoperable",
3958 curr_comp
->name
, derived_sym
->name
,
3963 curr_comp
= curr_comp
->next
;
3964 } while (curr_comp
!= NULL
);
3967 /* Make sure we don't have conflicts with the attributes. */
3968 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3970 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3971 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3972 &(derived_sym
->declared_at
));
3976 if (derived_sym
->attr
.sequence
!= 0)
3978 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3979 "attribute because it is BIND(C)", derived_sym
->name
,
3980 &(derived_sym
->declared_at
));
3984 /* Mark the derived type as not being C interoperable if we found an
3985 error. If there were only warnings, proceed with the assumption
3986 it's interoperable. */
3988 derived_sym
->ts
.is_c_interop
= 0;
3994 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3997 gen_special_c_interop_ptr (gfc_symbol
*tmp_sym
, gfc_symtree
*dt_symtree
)
4001 gcc_assert (tmp_sym
&& dt_symtree
&& dt_symtree
->n
.sym
);
4002 dt_symtree
->n
.sym
->attr
.referenced
= 1;
4004 tmp_sym
->attr
.is_c_interop
= 1;
4005 tmp_sym
->attr
.is_bind_c
= 1;
4006 tmp_sym
->ts
.is_c_interop
= 1;
4007 tmp_sym
->ts
.is_iso_c
= 1;
4008 tmp_sym
->ts
.type
= BT_DERIVED
;
4009 tmp_sym
->ts
.f90_type
= BT_VOID
;
4010 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4011 tmp_sym
->ts
.u
.derived
= dt_symtree
->n
.sym
;
4013 /* Set the c_address field of c_null_ptr and c_null_funptr to
4014 the value of NULL. */
4015 tmp_sym
->value
= gfc_get_expr ();
4016 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
4017 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
4018 tmp_sym
->value
->ts
.f90_type
= BT_VOID
;
4019 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
4020 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
4021 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
4022 c
->expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
4023 c
->expr
->ts
.is_iso_c
= 1;
4029 /* Add a formal argument, gfc_formal_arglist, to the
4030 end of the given list of arguments. Set the reference to the
4031 provided symbol, param_sym, in the argument. */
4034 add_formal_arg (gfc_formal_arglist
**head
,
4035 gfc_formal_arglist
**tail
,
4036 gfc_formal_arglist
*formal_arg
,
4037 gfc_symbol
*param_sym
)
4039 /* Put in list, either as first arg or at the tail (curr arg). */
4041 *head
= *tail
= formal_arg
;
4044 (*tail
)->next
= formal_arg
;
4045 (*tail
) = formal_arg
;
4048 (*tail
)->sym
= param_sym
;
4049 (*tail
)->next
= NULL
;
4055 /* Add a procedure interface to the given symbol (i.e., store a
4056 reference to the list of formal arguments). */
4059 add_proc_interface (gfc_symbol
*sym
, ifsrc source
, gfc_formal_arglist
*formal
)
4062 sym
->formal
= formal
;
4063 sym
->attr
.if_source
= source
;
4067 /* Copy the formal args from an existing symbol, src, into a new
4068 symbol, dest. New formal args are created, and the description of
4069 each arg is set according to the existing ones. This function is
4070 used when creating procedure declaration variables from a procedure
4071 declaration statement (see match_proc_decl()) to create the formal
4072 args based on the args of a given named interface. */
4075 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
4077 gfc_formal_arglist
*head
= NULL
;
4078 gfc_formal_arglist
*tail
= NULL
;
4079 gfc_formal_arglist
*formal_arg
= NULL
;
4080 gfc_intrinsic_arg
*curr_arg
= NULL
;
4081 gfc_formal_arglist
*formal_prev
= NULL
;
4082 /* Save current namespace so we can change it for formal args. */
4083 gfc_namespace
*parent_ns
= gfc_current_ns
;
4085 /* Create a new namespace, which will be the formal ns (namespace
4086 of the formal args). */
4087 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4088 gfc_current_ns
->proc_name
= dest
;
4090 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4092 formal_arg
= gfc_get_formal_arglist ();
4093 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4095 /* May need to copy more info for the symbol. */
4096 formal_arg
->sym
->ts
= curr_arg
->ts
;
4097 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4098 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4099 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4100 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4101 formal_arg
->sym
->attr
.dummy
= 1;
4103 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4104 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4106 /* If this isn't the first arg, set up the next ptr. For the
4107 last arg built, the formal_arg->next will never get set to
4108 anything other than NULL. */
4109 if (formal_prev
!= NULL
)
4110 formal_prev
->next
= formal_arg
;
4112 formal_arg
->next
= NULL
;
4114 formal_prev
= formal_arg
;
4116 /* Add arg to list of formal args. */
4117 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4119 /* Validate changes. */
4120 gfc_commit_symbol (formal_arg
->sym
);
4123 /* Add the interface to the symbol. */
4124 add_proc_interface (dest
, IFSRC_DECL
, head
);
4126 /* Store the formal namespace information. */
4127 if (dest
->formal
!= NULL
)
4128 /* The current ns should be that for the dest proc. */
4129 dest
->formal_ns
= gfc_current_ns
;
4130 /* Restore the current namespace to what it was on entry. */
4131 gfc_current_ns
= parent_ns
;
4136 std_for_isocbinding_symbol (int id
)
4140 #define NAMED_INTCST(a,b,c,d) \
4143 #include "iso-c-binding.def"
4146 #define NAMED_FUNCTION(a,b,c,d) \
4149 #define NAMED_SUBROUTINE(a,b,c,d) \
4152 #include "iso-c-binding.def"
4153 #undef NAMED_FUNCTION
4154 #undef NAMED_SUBROUTINE
4157 return GFC_STD_F2003
;
4161 /* Generate the given set of C interoperable kind objects, or all
4162 interoperable kinds. This function will only be given kind objects
4163 for valid iso_c_binding defined types because this is verified when
4164 the 'use' statement is parsed. If the user gives an 'only' clause,
4165 the specific kinds are looked up; if they don't exist, an error is
4166 reported. If the user does not give an 'only' clause, all
4167 iso_c_binding symbols are generated. If a list of specific kinds
4168 is given, it must have a NULL in the first empty spot to mark the
4169 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4170 point to the symtree for c_(fun)ptr. */
4173 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4174 const char *local_name
, gfc_symtree
*dt_symtree
,
4177 const char *const name
= (local_name
&& local_name
[0])
4178 ? local_name
: c_interop_kinds_table
[s
].name
;
4179 gfc_symtree
*tmp_symtree
;
4180 gfc_symbol
*tmp_sym
= NULL
;
4183 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4186 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4188 && (!tmp_symtree
|| !tmp_symtree
->n
.sym
4189 || tmp_symtree
->n
.sym
->from_intmod
!= INTMOD_ISO_C_BINDING
4190 || tmp_symtree
->n
.sym
->intmod_sym_id
!= s
))
4193 /* Already exists in this scope so don't re-add it. */
4194 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4195 && (!tmp_sym
->attr
.generic
4196 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4197 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4199 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4200 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4202 gfc_dt_list
*dt_list
;
4203 dt_list
= gfc_get_dt_list ();
4204 dt_list
->derived
= tmp_sym
;
4205 dt_list
->next
= gfc_derived_types
;
4206 gfc_derived_types
= dt_list
;
4212 /* Create the sym tree in the current ns. */
4215 tmp_symtree
= gfc_get_unique_symtree (gfc_current_ns
);
4216 tmp_sym
= gfc_new_symbol (name
, gfc_current_ns
);
4218 /* Add to the list of tentative symbols. */
4219 latest_undo_chgset
->syms
.safe_push (tmp_sym
);
4220 tmp_sym
->old_symbol
= NULL
;
4222 tmp_sym
->gfc_new
= 1;
4224 tmp_symtree
->n
.sym
= tmp_sym
;
4229 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4230 gcc_assert (tmp_symtree
);
4231 tmp_sym
= tmp_symtree
->n
.sym
;
4234 /* Say what module this symbol belongs to. */
4235 tmp_sym
->module
= gfc_get_string (mod_name
);
4236 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4237 tmp_sym
->intmod_sym_id
= s
;
4238 tmp_sym
->attr
.is_iso_c
= 1;
4239 tmp_sym
->attr
.use_assoc
= 1;
4241 gcc_assert (dt_symtree
== NULL
|| s
== ISOCBINDING_NULL_FUNPTR
4242 || s
== ISOCBINDING_NULL_PTR
);
4247 #define NAMED_INTCST(a,b,c,d) case a :
4248 #define NAMED_REALCST(a,b,c,d) case a :
4249 #define NAMED_CMPXCST(a,b,c,d) case a :
4250 #define NAMED_LOGCST(a,b,c) case a :
4251 #define NAMED_CHARKNDCST(a,b,c) case a :
4252 #include "iso-c-binding.def"
4254 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4255 c_interop_kinds_table
[s
].value
);
4257 /* Initialize an integer constant expression node. */
4258 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4259 tmp_sym
->ts
.type
= BT_INTEGER
;
4260 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4262 /* Mark this type as a C interoperable one. */
4263 tmp_sym
->ts
.is_c_interop
= 1;
4264 tmp_sym
->ts
.is_iso_c
= 1;
4265 tmp_sym
->value
->ts
.is_c_interop
= 1;
4266 tmp_sym
->value
->ts
.is_iso_c
= 1;
4267 tmp_sym
->attr
.is_c_interop
= 1;
4269 /* Tell what f90 type this c interop kind is valid. */
4270 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4275 #define NAMED_CHARCST(a,b,c) case a :
4276 #include "iso-c-binding.def"
4278 /* Initialize an integer constant expression node for the
4279 length of the character. */
4280 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4281 &gfc_current_locus
, NULL
, 1);
4282 tmp_sym
->value
->ts
.is_c_interop
= 1;
4283 tmp_sym
->value
->ts
.is_iso_c
= 1;
4284 tmp_sym
->value
->value
.character
.length
= 1;
4285 tmp_sym
->value
->value
.character
.string
[0]
4286 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4287 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4288 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4291 /* May not need this in both attr and ts, but do need in
4292 attr for writing module file. */
4293 tmp_sym
->attr
.is_c_interop
= 1;
4295 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4296 tmp_sym
->ts
.type
= BT_CHARACTER
;
4298 /* Need to set it to the C_CHAR kind. */
4299 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4301 /* Mark this type as a C interoperable one. */
4302 tmp_sym
->ts
.is_c_interop
= 1;
4303 tmp_sym
->ts
.is_iso_c
= 1;
4305 /* Tell what f90 type this c interop kind is valid. */
4306 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4310 case ISOCBINDING_PTR
:
4311 case ISOCBINDING_FUNPTR
:
4314 gfc_dt_list
**dt_list_ptr
= NULL
;
4315 gfc_component
*tmp_comp
= NULL
;
4317 /* Generate real derived type. */
4322 const char *hidden_name
;
4323 gfc_interface
*intr
, *head
;
4325 hidden_name
= gfc_get_string ("%c%s",
4326 (char) TOUPPER ((unsigned char)
4329 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4331 gcc_assert (tmp_symtree
== NULL
);
4332 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4333 dt_sym
= tmp_symtree
->n
.sym
;
4334 dt_sym
->name
= gfc_get_string (s
== ISOCBINDING_PTR
4335 ? "c_ptr" : "c_funptr");
4337 /* Generate an artificial generic function. */
4338 head
= tmp_sym
->generic
;
4339 intr
= gfc_get_interface ();
4341 intr
->where
= gfc_current_locus
;
4343 tmp_sym
->generic
= intr
;
4345 if (!tmp_sym
->attr
.generic
4346 && !gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4349 if (!tmp_sym
->attr
.function
4350 && !gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
))
4354 /* Say what module this symbol belongs to. */
4355 dt_sym
->module
= gfc_get_string (mod_name
);
4356 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4357 dt_sym
->intmod_sym_id
= s
;
4358 dt_sym
->attr
.use_assoc
= 1;
4360 /* Initialize an integer constant expression node. */
4361 dt_sym
->attr
.flavor
= FL_DERIVED
;
4362 dt_sym
->ts
.is_c_interop
= 1;
4363 dt_sym
->attr
.is_c_interop
= 1;
4364 dt_sym
->attr
.private_comp
= 1;
4365 dt_sym
->component_access
= ACCESS_PRIVATE
;
4366 dt_sym
->ts
.is_iso_c
= 1;
4367 dt_sym
->ts
.type
= BT_DERIVED
;
4368 dt_sym
->ts
.f90_type
= BT_VOID
;
4370 /* A derived type must have the bind attribute to be
4371 interoperable (J3/04-007, Section 15.2.3), even though
4372 the binding label is not used. */
4373 dt_sym
->attr
.is_bind_c
= 1;
4375 dt_sym
->attr
.referenced
= 1;
4376 dt_sym
->ts
.u
.derived
= dt_sym
;
4378 /* Add the symbol created for the derived type to the current ns. */
4379 dt_list_ptr
= &(gfc_derived_types
);
4380 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4381 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4383 /* There is already at least one derived type in the list, so append
4384 the one we're currently building for c_ptr or c_funptr. */
4385 if (*dt_list_ptr
!= NULL
)
4386 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4387 (*dt_list_ptr
) = gfc_get_dt_list ();
4388 (*dt_list_ptr
)->derived
= dt_sym
;
4389 (*dt_list_ptr
)->next
= NULL
;
4391 gfc_add_component (dt_sym
, "c_address", &tmp_comp
);
4392 if (tmp_comp
== NULL
)
4395 tmp_comp
->ts
.type
= BT_INTEGER
;
4397 /* Set this because the module will need to read/write this field. */
4398 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4400 /* The kinds for c_ptr and c_funptr are the same. */
4401 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4402 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4403 tmp_comp
->attr
.access
= ACCESS_PRIVATE
;
4405 /* Mark the component as C interoperable. */
4406 tmp_comp
->ts
.is_c_interop
= 1;
4411 case ISOCBINDING_NULL_PTR
:
4412 case ISOCBINDING_NULL_FUNPTR
:
4413 gen_special_c_interop_ptr (tmp_sym
, dt_symtree
);
4419 gfc_commit_symbol (tmp_sym
);
4424 /* Check that a symbol is already typed. If strict is not set, an untyped
4425 symbol is acceptable for non-standard-conforming mode. */
4428 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4429 bool strict
, locus where
)
4433 if (gfc_matching_prefix
)
4436 /* Check for the type and try to give it an implicit one. */
4437 if (sym
->ts
.type
== BT_UNKNOWN
4438 && !gfc_set_default_type (sym
, 0, ns
))
4442 gfc_error ("Symbol '%s' is used before it is typed at %L",
4447 if (!gfc_notify_std (GFC_STD_GNU
, "Symbol '%s' is used before"
4448 " it is typed at %L", sym
->name
, &where
))
4452 /* Everything is ok. */
4457 /* Construct a typebound-procedure structure. Those are stored in a tentative
4458 list and marked `error' until symbols are committed. */
4461 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4463 gfc_typebound_proc
*result
;
4465 result
= XCNEW (gfc_typebound_proc
);
4470 latest_undo_chgset
->tbps
.safe_push (result
);
4476 /* Get the super-type of a given derived type. */
4479 gfc_get_derived_super_type (gfc_symbol
* derived
)
4481 gcc_assert (derived
);
4483 if (derived
->attr
.generic
)
4484 derived
= gfc_find_dt_in_generic (derived
);
4486 if (!derived
->attr
.extension
)
4489 gcc_assert (derived
->components
);
4490 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4491 gcc_assert (derived
->components
->ts
.u
.derived
);
4493 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4494 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4496 return derived
->components
->ts
.u
.derived
;
4500 /* Get the ultimate super-type of a given derived type. */
4503 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4505 if (!derived
->attr
.extension
)
4508 derived
= gfc_get_derived_super_type (derived
);
4510 if (derived
->attr
.extension
)
4511 return gfc_get_ultimate_derived_super_type (derived
);
4517 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4520 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4522 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4523 t2
= gfc_get_derived_super_type (t2
);
4524 return gfc_compare_derived_types (t1
, t2
);
4528 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4529 If ts1 is nonpolymorphic, ts2 must be the same type.
4530 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4533 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4535 bool is_class1
= (ts1
->type
== BT_CLASS
);
4536 bool is_class2
= (ts2
->type
== BT_CLASS
);
4537 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4538 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4541 && ts1
->u
.derived
->components
4542 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4545 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
)
4546 return (ts1
->type
== ts2
->type
);
4548 if (is_derived1
&& is_derived2
)
4549 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4551 if (is_derived1
&& is_class2
)
4552 return gfc_compare_derived_types (ts1
->u
.derived
,
4553 ts2
->u
.derived
->components
->ts
.u
.derived
);
4554 if (is_class1
&& is_derived2
)
4555 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4557 else if (is_class1
&& is_class2
)
4558 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4559 ts2
->u
.derived
->components
->ts
.u
.derived
);
4565 /* Find the parent-namespace of the current function. If we're inside
4566 BLOCK constructs, it may not be the current one. */
4569 gfc_find_proc_namespace (gfc_namespace
* ns
)
4571 while (ns
->construct_entities
)
4581 /* Check if an associate-variable should be translated as an `implicit' pointer
4582 internally (if it is associated to a variable and not an array with
4586 gfc_is_associate_pointer (gfc_symbol
* sym
)
4591 if (sym
->ts
.type
== BT_CLASS
)
4594 if (!sym
->assoc
->variable
)
4597 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
4605 gfc_find_dt_in_generic (gfc_symbol
*sym
)
4607 gfc_interface
*intr
= NULL
;
4609 if (!sym
|| sym
->attr
.flavor
== FL_DERIVED
)
4612 if (sym
->attr
.generic
)
4613 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
4614 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
4616 return intr
? intr
->sym
: NULL
;
4620 /* Get the dummy arguments from a procedure symbol. If it has been declared
4621 via a PROCEDURE statement with a named interface, ts.interface will be set
4622 and the arguments need to be taken from there. */
4624 gfc_formal_arglist
*
4625 gfc_sym_get_dummy_args (gfc_symbol
*sym
)
4627 gfc_formal_arglist
*dummies
;
4629 dummies
= sym
->formal
;
4630 if (dummies
== NULL
&& sym
->ts
.interface
!= NULL
)
4631 dummies
= sym
->ts
.interface
->formal
;