1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors
[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
41 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
42 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
43 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
47 const mstring procedures
[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
50 minit ("MODULE-PROC", PROC_MODULE
),
51 minit ("INTERNAL-PROC", PROC_INTERNAL
),
52 minit ("DUMMY-PROC", PROC_DUMMY
),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
59 const mstring intents
[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
62 minit ("IN", INTENT_IN
),
63 minit ("OUT", INTENT_OUT
),
64 minit ("INOUT", INTENT_INOUT
),
68 const mstring access_types
[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
71 minit ("PUBLIC", ACCESS_PUBLIC
),
72 minit ("PRIVATE", ACCESS_PRIVATE
),
76 const mstring ifsrc_types
[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN
),
79 minit ("DECL", IFSRC_DECL
),
80 minit ("BODY", IFSRC_IFBODY
)
83 const mstring save_status
[] =
85 minit ("UNKNOWN", SAVE_NONE
),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order
= 1;
96 gfc_namespace
*gfc_current_ns
;
97 gfc_namespace
*gfc_global_ns_list
;
99 gfc_gsymbol
*gfc_gsym_root
= NULL
;
101 static gfc_symbol
*changed_syms
= NULL
;
103 gfc_dt_list
*gfc_derived_types
;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc
*proc
;
111 struct tentative_tbp
*next
;
115 static tentative_tbp
*tentative_tbp_list
= NULL
;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag
[GFC_LETTERS
];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns
->seen_implicit_none
)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns
->seen_implicit_none
= 1;
141 for (i
= 0; i
< GFC_LETTERS
; i
++)
143 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
144 gfc_current_ns
->set_flag
[i
] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i
= 0; i
< GFC_LETTERS
; i
++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1
, int c2
)
171 for (i
= c1
; i
<= c2
; i
++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec
*ts
)
195 if (gfc_current_ns
->seen_implicit_none
)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i
= 0; i
< GFC_LETTERS
; i
++)
205 if (gfc_current_ns
->set_flag
[i
])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns
->default_type
[i
] = *ts
;
213 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
214 gfc_current_ns
->set_flag
[i
] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
230 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter
< 'a' || letter
> 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name
);
241 return &ns
->default_type
[letter
- 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
254 if (sym
->ts
.type
!= BT_UNKNOWN
)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts
= gfc_get_default_type (sym
->name
, ns
);
259 if (ts
->type
== BT_UNKNOWN
)
261 if (error_flag
&& !sym
->attr
.untyped
)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym
->name
, &sym
->declared_at
);
265 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
272 sym
->attr
.implicit_type
= 1;
274 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
275 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
277 if (sym
->attr
.is_bind_c
== 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym
->name
, &sym
->declared_at
);
282 sym
->ts
.f90_type
= sym
->ts
.type
;
285 if (sym
->attr
.dummy
!= 0)
287 if (sym
->ns
->proc_name
!= NULL
288 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
289 || sym
->ns
->proc_name
->attr
.function
!= 0)
290 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym
->name
,
297 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
298 &(sym
->ns
->proc_name
->declared_at
));
299 sym
->ts
.f90_type
= sym
->ts
.type
;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace
*ns
)
314 gfc_symbol
*proc
= ns
->proc_name
;
316 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
319 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
321 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
324 if (proc
->result
!= proc
)
326 proc
->ts
= proc
->result
->ts
;
327 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
328 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
329 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
330 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
333 else if (!proc
->result
->attr
.proc_pointer
)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc
->result
->name
, &proc
->result
->declared_at
);
337 proc
->result
->attr
.untyped
= 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
361 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
362 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
363 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
364 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
365 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
366 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
367 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
368 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
369 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
370 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
371 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
372 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
373 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
374 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
375 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
376 *contiguous
= "CONTIGUOUS";
377 static const char *threadprivate
= "THREADPRIVATE";
383 where
= &gfc_current_locus
;
385 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
389 standard
= GFC_STD_F2003
;
393 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
396 a2
= attr
->allocatable
? allocatable
: pointer
;
397 standard
= GFC_STD_F2003
;
401 /* Check for attributes not allowed in a BLOCK DATA. */
402 if (gfc_current_state () == COMP_BLOCK_DATA
)
406 if (attr
->in_namelist
)
408 if (attr
->allocatable
)
414 if (attr
->access
== ACCESS_PRIVATE
)
416 if (attr
->access
== ACCESS_PUBLIC
)
418 if (attr
->intent
!= INTENT_UNKNOWN
)
424 ("%s attribute not allowed in BLOCK DATA program unit at %L",
430 if (attr
->save
== SAVE_EXPLICIT
)
433 conf (in_common
, save
);
436 switch (attr
->flavor
)
444 a1
= gfc_code2string (flavors
, attr
->flavor
);
449 /* Conflicts between SAVE and PROCEDURE will be checked at
450 resolution stage, see "resolve_fl_procedure". */
459 conf (dummy
, intrinsic
);
460 conf (dummy
, threadprivate
);
461 conf (pointer
, target
);
462 conf (pointer
, intrinsic
);
463 conf (pointer
, elemental
);
464 conf (allocatable
, elemental
);
466 conf (target
, external
);
467 conf (target
, intrinsic
);
469 if (!attr
->if_source
)
470 conf (external
, dimension
); /* See Fortran 95's R504. */
472 conf (external
, intrinsic
);
473 conf (entry
, intrinsic
);
475 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
476 conf (external
, subroutine
);
478 if (attr
->proc_pointer
&& gfc_notify_std (GFC_STD_F2003
,
479 "Fortran 2003: Procedure pointer at %C") == FAILURE
)
482 conf (allocatable
, pointer
);
483 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
484 conf_std (allocatable
, function
, GFC_STD_F2003
);
485 conf_std (allocatable
, result
, GFC_STD_F2003
);
486 conf (elemental
, recursive
);
488 conf (in_common
, dummy
);
489 conf (in_common
, allocatable
);
490 conf (in_common
, codimension
);
491 conf (in_common
, result
);
493 conf (dummy
, result
);
495 conf (in_equivalence
, use_assoc
);
496 conf (in_equivalence
, codimension
);
497 conf (in_equivalence
, dummy
);
498 conf (in_equivalence
, target
);
499 conf (in_equivalence
, pointer
);
500 conf (in_equivalence
, function
);
501 conf (in_equivalence
, result
);
502 conf (in_equivalence
, entry
);
503 conf (in_equivalence
, allocatable
);
504 conf (in_equivalence
, threadprivate
);
506 conf (entry
, result
);
508 conf (function
, subroutine
);
510 if (!function
&& !subroutine
)
511 conf (is_bind_c
, dummy
);
513 conf (is_bind_c
, cray_pointer
);
514 conf (is_bind_c
, cray_pointee
);
515 conf (is_bind_c
, codimension
);
516 conf (is_bind_c
, allocatable
);
517 conf (is_bind_c
, elemental
);
519 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
520 Parameter conflict caught below. Also, value cannot be specified
521 for a dummy procedure. */
523 /* Cray pointer/pointee conflicts. */
524 conf (cray_pointer
, cray_pointee
);
525 conf (cray_pointer
, dimension
);
526 conf (cray_pointer
, codimension
);
527 conf (cray_pointer
, contiguous
);
528 conf (cray_pointer
, pointer
);
529 conf (cray_pointer
, target
);
530 conf (cray_pointer
, allocatable
);
531 conf (cray_pointer
, external
);
532 conf (cray_pointer
, intrinsic
);
533 conf (cray_pointer
, in_namelist
);
534 conf (cray_pointer
, function
);
535 conf (cray_pointer
, subroutine
);
536 conf (cray_pointer
, entry
);
538 conf (cray_pointee
, allocatable
);
539 conf (cray_pointer
, contiguous
);
540 conf (cray_pointer
, codimension
);
541 conf (cray_pointee
, intent
);
542 conf (cray_pointee
, optional
);
543 conf (cray_pointee
, dummy
);
544 conf (cray_pointee
, target
);
545 conf (cray_pointee
, intrinsic
);
546 conf (cray_pointee
, pointer
);
547 conf (cray_pointee
, entry
);
548 conf (cray_pointee
, in_common
);
549 conf (cray_pointee
, in_equivalence
);
550 conf (cray_pointee
, threadprivate
);
553 conf (data
, function
);
555 conf (data
, allocatable
);
557 conf (value
, pointer
)
558 conf (value
, allocatable
)
559 conf (value
, subroutine
)
560 conf (value
, function
)
561 conf (value
, volatile_
)
562 conf (value
, dimension
)
563 conf (value
, codimension
)
564 conf (value
, external
)
566 conf (codimension
, result
)
569 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
572 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
576 conf (is_protected
, intrinsic
)
577 conf (is_protected
, in_common
)
579 conf (asynchronous
, intrinsic
)
580 conf (asynchronous
, external
)
582 conf (volatile_
, intrinsic
)
583 conf (volatile_
, external
)
585 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
592 conf (procedure
, allocatable
)
593 conf (procedure
, dimension
)
594 conf (procedure
, codimension
)
595 conf (procedure
, intrinsic
)
596 conf (procedure
, target
)
597 conf (procedure
, value
)
598 conf (procedure
, volatile_
)
599 conf (procedure
, asynchronous
)
600 conf (procedure
, entry
)
602 a1
= gfc_code2string (flavors
, attr
->flavor
);
604 if (attr
->in_namelist
605 && attr
->flavor
!= FL_VARIABLE
606 && attr
->flavor
!= FL_PROCEDURE
607 && attr
->flavor
!= FL_UNKNOWN
)
613 switch (attr
->flavor
)
623 conf2 (asynchronous
);
626 conf2 (is_protected
);
636 conf2 (threadprivate
);
638 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
640 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
641 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
648 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
662 /* Conflicts with INTENT, SAVE and RESULT will be checked
663 at resolution stage, see "resolve_fl_procedure". */
665 if (attr
->subroutine
)
671 conf2 (asynchronous
);
676 conf2 (threadprivate
);
679 if (!attr
->proc_pointer
)
684 case PROC_ST_FUNCTION
:
694 conf2 (threadprivate
);
714 conf2 (threadprivate
);
717 if (attr
->intent
!= INTENT_UNKNOWN
)
734 conf2 (is_protected
);
740 conf2 (asynchronous
);
741 conf2 (threadprivate
);
756 gfc_error ("%s attribute conflicts with %s attribute at %L",
759 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
760 a1
, a2
, name
, where
);
767 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
768 "with %s attribute at %L", a1
, a2
,
773 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
774 "with %s attribute in '%s' at %L",
775 a1
, a2
, name
, where
);
784 /* Mark a symbol as referenced. */
787 gfc_set_sym_referenced (gfc_symbol
*sym
)
790 if (sym
->attr
.referenced
)
793 sym
->attr
.referenced
= 1;
795 /* Remember which order dummy variables are accessed in. */
797 sym
->dummy_order
= next_dummy_order
++;
801 /* Common subroutine called by attribute changing subroutines in order
802 to prevent them from changing a symbol that has been
803 use-associated. Returns zero if it is OK to change the symbol,
807 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
810 if (attr
->use_assoc
== 0)
814 where
= &gfc_current_locus
;
817 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
820 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
827 /* Generate an error because of a duplicate attribute. */
830 duplicate_attr (const char *attr
, locus
*where
)
834 where
= &gfc_current_locus
;
836 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
841 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
842 locus
*where ATTRIBUTE_UNUSED
)
844 attr
->ext_attr
|= 1 << ext_attr
;
849 /* Called from decl.c (attr_decl1) to check attributes, when declared
853 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
855 if (check_used (attr
, NULL
, where
))
858 return check_conflict (attr
, NULL
, where
);
863 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
866 if (check_used (attr
, NULL
, where
))
869 if (attr
->allocatable
)
871 duplicate_attr ("ALLOCATABLE", where
);
875 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
876 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
878 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
883 attr
->allocatable
= 1;
884 return check_conflict (attr
, NULL
, where
);
889 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
892 if (check_used (attr
, name
, where
))
895 if (attr
->codimension
)
897 duplicate_attr ("CODIMENSION", where
);
901 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
902 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
904 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
905 "at %L", name
, where
);
909 attr
->codimension
= 1;
910 return check_conflict (attr
, name
, where
);
915 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
918 if (check_used (attr
, name
, where
))
923 duplicate_attr ("DIMENSION", where
);
927 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
928 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
930 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
931 "at %L", name
, where
);
936 return check_conflict (attr
, name
, where
);
941 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
944 if (check_used (attr
, name
, where
))
947 attr
->contiguous
= 1;
948 return check_conflict (attr
, name
, where
);
953 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
956 if (check_used (attr
, NULL
, where
))
961 duplicate_attr ("EXTERNAL", where
);
965 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
968 attr
->proc_pointer
= 1;
973 return check_conflict (attr
, NULL
, where
);
978 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
981 if (check_used (attr
, NULL
, where
))
986 duplicate_attr ("INTRINSIC", where
);
992 return check_conflict (attr
, NULL
, where
);
997 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1000 if (check_used (attr
, NULL
, where
))
1005 duplicate_attr ("OPTIONAL", where
);
1010 return check_conflict (attr
, NULL
, where
);
1015 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1018 if (check_used (attr
, NULL
, where
))
1021 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1022 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1024 duplicate_attr ("POINTER", where
);
1028 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1029 || (attr
->if_source
== IFSRC_IFBODY
1030 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1031 attr
->proc_pointer
= 1;
1035 return check_conflict (attr
, NULL
, where
);
1040 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1043 if (check_used (attr
, NULL
, where
))
1046 attr
->cray_pointer
= 1;
1047 return check_conflict (attr
, NULL
, where
);
1052 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1055 if (check_used (attr
, NULL
, where
))
1058 if (attr
->cray_pointee
)
1060 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1061 " statements", where
);
1065 attr
->cray_pointee
= 1;
1066 return check_conflict (attr
, NULL
, where
);
1071 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1073 if (check_used (attr
, name
, where
))
1076 if (attr
->is_protected
)
1078 if (gfc_notify_std (GFC_STD_LEGACY
,
1079 "Duplicate PROTECTED attribute specified at %L",
1085 attr
->is_protected
= 1;
1086 return check_conflict (attr
, name
, where
);
1091 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1094 if (check_used (attr
, name
, where
))
1098 return check_conflict (attr
, name
, where
);
1103 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1107 if (check_used (attr
, name
, where
))
1110 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1113 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1118 if (s
== SAVE_EXPLICIT
&& gfc_implicit_pure (NULL
))
1119 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1121 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1123 if (gfc_notify_std (GFC_STD_LEGACY
,
1124 "Duplicate SAVE attribute specified at %L",
1131 return check_conflict (attr
, name
, where
);
1136 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1139 if (check_used (attr
, name
, where
))
1144 if (gfc_notify_std (GFC_STD_LEGACY
,
1145 "Duplicate VALUE attribute specified at %L",
1152 return check_conflict (attr
, name
, where
);
1157 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1159 /* No check_used needed as 11.2.1 of the F2003 standard allows
1160 that the local identifier made accessible by a use statement can be
1161 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1163 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1164 if (gfc_notify_std (GFC_STD_LEGACY
,
1165 "Duplicate VOLATILE attribute specified at %L", where
)
1169 attr
->volatile_
= 1;
1170 attr
->volatile_ns
= gfc_current_ns
;
1171 return check_conflict (attr
, name
, where
);
1176 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1178 /* No check_used needed as 11.2.1 of the F2003 standard allows
1179 that the local identifier made accessible by a use statement can be
1180 given a ASYNCHRONOUS attribute. */
1182 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1183 if (gfc_notify_std (GFC_STD_LEGACY
,
1184 "Duplicate ASYNCHRONOUS attribute specified at %L",
1188 attr
->asynchronous
= 1;
1189 attr
->asynchronous_ns
= gfc_current_ns
;
1190 return check_conflict (attr
, name
, where
);
1195 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1198 if (check_used (attr
, name
, where
))
1201 if (attr
->threadprivate
)
1203 duplicate_attr ("THREADPRIVATE", where
);
1207 attr
->threadprivate
= 1;
1208 return check_conflict (attr
, name
, where
);
1213 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1216 if (check_used (attr
, NULL
, where
))
1221 duplicate_attr ("TARGET", where
);
1226 return check_conflict (attr
, NULL
, where
);
1231 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1234 if (check_used (attr
, name
, where
))
1237 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1239 return check_conflict (attr
, name
, where
);
1244 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1247 if (check_used (attr
, name
, where
))
1250 /* Duplicate attribute already checked for. */
1251 attr
->in_common
= 1;
1252 return check_conflict (attr
, name
, where
);
1257 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1260 /* Duplicate attribute already checked for. */
1261 attr
->in_equivalence
= 1;
1262 if (check_conflict (attr
, name
, where
) == FAILURE
)
1265 if (attr
->flavor
== FL_VARIABLE
)
1268 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1273 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1276 if (check_used (attr
, name
, where
))
1280 return check_conflict (attr
, name
, where
);
1285 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1288 attr
->in_namelist
= 1;
1289 return check_conflict (attr
, name
, where
);
1294 gfc_add_sequence (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_elemental (symbol_attribute
*attr
, locus
*where
)
1309 if (check_used (attr
, NULL
, where
))
1312 if (attr
->elemental
)
1314 duplicate_attr ("ELEMENTAL", where
);
1318 attr
->elemental
= 1;
1319 return check_conflict (attr
, NULL
, where
);
1324 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1327 if (check_used (attr
, NULL
, where
))
1332 duplicate_attr ("PURE", where
);
1337 return check_conflict (attr
, NULL
, where
);
1342 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1345 if (check_used (attr
, NULL
, where
))
1348 if (attr
->recursive
)
1350 duplicate_attr ("RECURSIVE", where
);
1354 attr
->recursive
= 1;
1355 return check_conflict (attr
, NULL
, where
);
1360 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1363 if (check_used (attr
, name
, where
))
1368 duplicate_attr ("ENTRY", where
);
1373 return check_conflict (attr
, name
, where
);
1378 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1381 if (attr
->flavor
!= FL_PROCEDURE
1382 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1386 return check_conflict (attr
, name
, where
);
1391 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1394 if (attr
->flavor
!= FL_PROCEDURE
1395 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1398 attr
->subroutine
= 1;
1399 return check_conflict (attr
, name
, where
);
1404 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1407 if (attr
->flavor
!= FL_PROCEDURE
1408 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1412 return check_conflict (attr
, name
, where
);
1417 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1420 if (check_used (attr
, NULL
, where
))
1423 if (attr
->flavor
!= FL_PROCEDURE
1424 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1427 if (attr
->procedure
)
1429 duplicate_attr ("PROCEDURE", where
);
1433 attr
->procedure
= 1;
1435 return check_conflict (attr
, NULL
, where
);
1440 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1444 duplicate_attr ("ABSTRACT", where
);
1453 /* Flavors are special because some flavors are not what Fortran
1454 considers attributes and can be reaffirmed multiple times. */
1457 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1461 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1462 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1463 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1466 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1469 if (attr
->flavor
!= FL_UNKNOWN
)
1472 where
= &gfc_current_locus
;
1475 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1476 gfc_code2string (flavors
, attr
->flavor
), name
,
1477 gfc_code2string (flavors
, f
), where
);
1479 gfc_error ("%s attribute conflicts with %s attribute at %L",
1480 gfc_code2string (flavors
, attr
->flavor
),
1481 gfc_code2string (flavors
, f
), where
);
1488 return check_conflict (attr
, name
, where
);
1493 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1494 const char *name
, locus
*where
)
1497 if (check_used (attr
, name
, where
))
1500 if (attr
->flavor
!= FL_PROCEDURE
1501 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1505 where
= &gfc_current_locus
;
1507 if (attr
->proc
!= PROC_UNKNOWN
)
1509 gfc_error ("%s procedure at %L is already declared as %s procedure",
1510 gfc_code2string (procedures
, t
), where
,
1511 gfc_code2string (procedures
, attr
->proc
));
1518 /* Statement functions are always scalar and functions. */
1519 if (t
== PROC_ST_FUNCTION
1520 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1521 || attr
->dimension
))
1524 return check_conflict (attr
, name
, where
);
1529 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1532 if (check_used (attr
, NULL
, where
))
1535 if (attr
->intent
== INTENT_UNKNOWN
)
1537 attr
->intent
= intent
;
1538 return check_conflict (attr
, NULL
, where
);
1542 where
= &gfc_current_locus
;
1544 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1545 gfc_intent_string (attr
->intent
),
1546 gfc_intent_string (intent
), where
);
1552 /* No checks for use-association in public and private statements. */
1555 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1556 const char *name
, locus
*where
)
1559 if (attr
->access
== ACCESS_UNKNOWN
1560 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1562 attr
->access
= access
;
1563 return check_conflict (attr
, name
, where
);
1567 where
= &gfc_current_locus
;
1568 gfc_error ("ACCESS specification at %L was already specified", where
);
1574 /* Set the is_bind_c field for the given symbol_attribute. */
1577 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1578 int is_proc_lang_bind_spec
)
1581 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1582 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1583 "variables or common blocks", where
);
1584 else if (attr
->is_bind_c
)
1585 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1587 attr
->is_bind_c
= 1;
1590 where
= &gfc_current_locus
;
1592 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1596 return check_conflict (attr
, name
, where
);
1600 /* Set the extension field for the given symbol_attribute. */
1603 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1606 where
= &gfc_current_locus
;
1608 if (attr
->extension
)
1609 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1611 attr
->extension
= 1;
1613 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1622 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1623 gfc_formal_arglist
* formal
, locus
*where
)
1626 if (check_used (&sym
->attr
, sym
->name
, where
))
1630 where
= &gfc_current_locus
;
1632 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1633 && sym
->attr
.if_source
!= IFSRC_DECL
)
1635 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1640 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1642 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1643 "body", sym
->name
, where
);
1647 sym
->formal
= formal
;
1648 sym
->attr
.if_source
= source
;
1654 /* Add a type to a symbol. */
1657 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1663 where
= &gfc_current_locus
;
1666 type
= sym
->result
->ts
.type
;
1668 type
= sym
->ts
.type
;
1670 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1671 type
= sym
->ns
->proc_name
->ts
.type
;
1673 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1675 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1676 where
, gfc_basic_typename (type
));
1680 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1682 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1683 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1687 flavor
= sym
->attr
.flavor
;
1689 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1690 || flavor
== FL_LABEL
1691 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1692 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1694 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1703 /* Clears all attributes. */
1706 gfc_clear_attr (symbol_attribute
*attr
)
1708 memset (attr
, 0, sizeof (symbol_attribute
));
1712 /* Check for missing attributes in the new symbol. Currently does
1713 nothing, but it's not clear that it is unnecessary yet. */
1716 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1717 locus
*where ATTRIBUTE_UNUSED
)
1724 /* Copy an attribute to a symbol attribute, bit by bit. Some
1725 attributes have a lot of side-effects but cannot be present given
1726 where we are called from, so we ignore some bits. */
1729 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1731 int is_proc_lang_bind_spec
;
1733 /* In line with the other attributes, we only add bits but do not remove
1734 them; cf. also PR 41034. */
1735 dest
->ext_attr
|= src
->ext_attr
;
1737 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1740 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1742 if (src
->codimension
&& gfc_add_codimension (dest
, NULL
, where
) == FAILURE
)
1744 if (src
->contiguous
&& gfc_add_contiguous (dest
, NULL
, where
) == FAILURE
)
1746 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1748 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1750 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1752 if (src
->save
&& gfc_add_save (dest
, src
->save
, NULL
, where
) == FAILURE
)
1754 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1756 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1758 if (src
->asynchronous
&& gfc_add_asynchronous (dest
, NULL
, where
) == FAILURE
)
1760 if (src
->threadprivate
1761 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1763 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1765 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1767 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1772 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1775 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1778 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1780 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1782 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1785 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1787 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1789 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1791 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1794 if (src
->flavor
!= FL_UNKNOWN
1795 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1798 if (src
->intent
!= INTENT_UNKNOWN
1799 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1802 if (src
->access
!= ACCESS_UNKNOWN
1803 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1806 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1809 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1811 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1814 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1816 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1820 if (src
->is_c_interop
)
1821 dest
->is_c_interop
= 1;
1825 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1827 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1829 if (src
->proc_pointer
)
1830 dest
->proc_pointer
= 1;
1839 /************** Component name management ************/
1841 /* Component names of a derived type form their own little namespaces
1842 that are separate from all other spaces. The space is composed of
1843 a singly linked list of gfc_component structures whose head is
1844 located in the parent symbol. */
1847 /* Add a component name to a symbol. The call fails if the name is
1848 already present. On success, the component pointer is modified to
1849 point to the additional component structure. */
1852 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1853 gfc_component
**component
)
1855 gfc_component
*p
, *tail
;
1859 for (p
= sym
->components
; p
; p
= p
->next
)
1861 if (strcmp (p
->name
, name
) == 0)
1863 gfc_error ("Component '%s' at %C already declared at %L",
1871 if (sym
->attr
.extension
1872 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1874 gfc_error ("Component '%s' at %C already in the parent type "
1875 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1879 /* Allocate a new component. */
1880 p
= gfc_get_component ();
1883 sym
->components
= p
;
1887 p
->name
= gfc_get_string (name
);
1888 p
->loc
= gfc_current_locus
;
1889 p
->ts
.type
= BT_UNKNOWN
;
1896 /* Recursive function to switch derived types of all symbol in a
1900 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1908 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1909 sym
->ts
.u
.derived
= to
;
1911 switch_types (st
->left
, from
, to
);
1912 switch_types (st
->right
, from
, to
);
1916 /* This subroutine is called when a derived type is used in order to
1917 make the final determination about which version to use. The
1918 standard requires that a type be defined before it is 'used', but
1919 such types can appear in IMPLICIT statements before the actual
1920 definition. 'Using' in this context means declaring a variable to
1921 be that type or using the type constructor.
1923 If a type is used and the components haven't been defined, then we
1924 have to have a derived type in a parent unit. We find the node in
1925 the other namespace and point the symtree node in this namespace to
1926 that node. Further reference to this name point to the correct
1927 node. If we can't find the node in a parent namespace, then we have
1930 This subroutine takes a pointer to a symbol node and returns a
1931 pointer to the translated node or NULL for an error. Usually there
1932 is no translation and we return the node we were passed. */
1935 gfc_use_derived (gfc_symbol
*sym
)
1942 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1943 return sym
; /* Already defined. */
1945 if (sym
->ns
->parent
== NULL
)
1948 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1950 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1954 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1957 /* Get rid of symbol sym, translating all references to s. */
1958 for (i
= 0; i
< GFC_LETTERS
; i
++)
1960 t
= &sym
->ns
->default_type
[i
];
1961 if (t
->u
.derived
== sym
)
1965 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1970 /* Unlink from list of modified symbols. */
1971 gfc_commit_symbol (sym
);
1973 switch_types (sym
->ns
->sym_root
, sym
, s
);
1975 /* TODO: Also have to replace sym -> s in other lists like
1976 namelists, common lists and interface lists. */
1977 gfc_free_symbol (sym
);
1982 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1988 /* Given a derived type node and a component name, try to locate the
1989 component structure. Returns the NULL pointer if the component is
1990 not found or the components are private. If noaccess is set, no access
1994 gfc_find_component (gfc_symbol
*sym
, const char *name
,
1995 bool noaccess
, bool silent
)
1999 if (name
== NULL
|| sym
== NULL
)
2002 sym
= gfc_use_derived (sym
);
2007 for (p
= sym
->components
; p
; p
= p
->next
)
2008 if (strcmp (p
->name
, name
) == 0)
2012 && sym
->attr
.extension
2013 && sym
->components
->ts
.type
== BT_DERIVED
)
2015 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2017 /* Do not overwrite the error. */
2022 if (p
== NULL
&& !silent
)
2023 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2026 else if (sym
->attr
.use_assoc
&& !noaccess
)
2028 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2029 if (p
->attr
.access
== ACCESS_PRIVATE
||
2030 (p
->attr
.access
!= ACCESS_PUBLIC
2031 && sym
->component_access
== ACCESS_PRIVATE
2032 && !is_parent_comp
))
2035 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2045 /* Given a symbol, free all of the component structures and everything
2049 free_components (gfc_component
*p
)
2057 gfc_free_array_spec (p
->as
);
2058 gfc_free_expr (p
->initializer
);
2060 gfc_free_formal_arglist (p
->formal
);
2061 gfc_free_namespace (p
->formal_ns
);
2068 /******************** Statement label management ********************/
2070 /* Comparison function for statement labels, used for managing the
2074 compare_st_labels (void *a1
, void *b1
)
2076 int a
= ((gfc_st_label
*) a1
)->value
;
2077 int b
= ((gfc_st_label
*) b1
)->value
;
2083 /* Free a single gfc_st_label structure, making sure the tree is not
2084 messed up. This function is called only when some parse error
2088 gfc_free_st_label (gfc_st_label
*label
)
2094 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2096 if (label
->format
!= NULL
)
2097 gfc_free_expr (label
->format
);
2103 /* Free a whole tree of gfc_st_label structures. */
2106 free_st_labels (gfc_st_label
*label
)
2112 free_st_labels (label
->left
);
2113 free_st_labels (label
->right
);
2115 if (label
->format
!= NULL
)
2116 gfc_free_expr (label
->format
);
2121 /* Given a label number, search for and return a pointer to the label
2122 structure, creating it if it does not exist. */
2125 gfc_get_st_label (int labelno
)
2130 if (gfc_current_state () == COMP_DERIVED
)
2131 ns
= gfc_current_block ()->f2k_derived
;
2134 /* Find the namespace of the scoping unit:
2135 If we're in a BLOCK construct, jump to the parent namespace. */
2136 ns
= gfc_current_ns
;
2137 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2141 /* First see if the label is already in this namespace. */
2145 if (lp
->value
== labelno
)
2148 if (lp
->value
< labelno
)
2154 lp
= XCNEW (gfc_st_label
);
2156 lp
->value
= labelno
;
2157 lp
->defined
= ST_LABEL_UNKNOWN
;
2158 lp
->referenced
= ST_LABEL_UNKNOWN
;
2160 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2166 /* Called when a statement with a statement label is about to be
2167 accepted. We add the label to the list of the current namespace,
2168 making sure it hasn't been defined previously and referenced
2172 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2176 labelno
= lp
->value
;
2178 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2179 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2180 &lp
->where
, label_locus
);
2183 lp
->where
= *label_locus
;
2187 case ST_LABEL_FORMAT
:
2188 if (lp
->referenced
== ST_LABEL_TARGET
)
2189 gfc_error ("Label %d at %C already referenced as branch target",
2192 lp
->defined
= ST_LABEL_FORMAT
;
2196 case ST_LABEL_TARGET
:
2197 if (lp
->referenced
== ST_LABEL_FORMAT
)
2198 gfc_error ("Label %d at %C already referenced as a format label",
2201 lp
->defined
= ST_LABEL_TARGET
;
2206 lp
->defined
= ST_LABEL_BAD_TARGET
;
2207 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2213 /* Reference a label. Given a label and its type, see if that
2214 reference is consistent with what is known about that label,
2215 updating the unknown state. Returns FAILURE if something goes
2219 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2221 gfc_sl_type label_type
;
2228 labelno
= lp
->value
;
2230 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2231 label_type
= lp
->defined
;
2234 label_type
= lp
->referenced
;
2235 lp
->where
= gfc_current_locus
;
2238 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2240 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2245 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2246 && type
== ST_LABEL_FORMAT
)
2248 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2253 lp
->referenced
= type
;
2261 /************** Symbol table management subroutines ****************/
2263 /* Basic details: Fortran 95 requires a potentially unlimited number
2264 of distinct namespaces when compiling a program unit. This case
2265 occurs during a compilation of internal subprograms because all of
2266 the internal subprograms must be read before we can start
2267 generating code for the host.
2269 Given the tricky nature of the Fortran grammar, we must be able to
2270 undo changes made to a symbol table if the current interpretation
2271 of a statement is found to be incorrect. Whenever a symbol is
2272 looked up, we make a copy of it and link to it. All of these
2273 symbols are kept in a singly linked list so that we can commit or
2274 undo the changes at a later time.
2276 A symtree may point to a symbol node outside of its namespace. In
2277 this case, that symbol has been used as a host associated variable
2278 at some previous time. */
2280 /* Allocate a new namespace structure. Copies the implicit types from
2281 PARENT if PARENT_TYPES is set. */
2284 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2291 ns
= XCNEW (gfc_namespace
);
2292 ns
->sym_root
= NULL
;
2293 ns
->uop_root
= NULL
;
2294 ns
->tb_sym_root
= NULL
;
2295 ns
->finalizers
= NULL
;
2296 ns
->default_access
= ACCESS_UNKNOWN
;
2297 ns
->parent
= parent
;
2299 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2301 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2302 ns
->tb_op
[in
] = NULL
;
2305 /* Initialize default implicit types. */
2306 for (i
= 'a'; i
<= 'z'; i
++)
2308 ns
->set_flag
[i
- 'a'] = 0;
2309 ts
= &ns
->default_type
[i
- 'a'];
2311 if (parent_types
&& ns
->parent
!= NULL
)
2313 /* Copy parent settings. */
2314 *ts
= ns
->parent
->default_type
[i
- 'a'];
2318 if (gfc_option
.flag_implicit_none
!= 0)
2324 if ('i' <= i
&& i
<= 'n')
2326 ts
->type
= BT_INTEGER
;
2327 ts
->kind
= gfc_default_integer_kind
;
2332 ts
->kind
= gfc_default_real_kind
;
2342 /* Comparison function for symtree nodes. */
2345 compare_symtree (void *_st1
, void *_st2
)
2347 gfc_symtree
*st1
, *st2
;
2349 st1
= (gfc_symtree
*) _st1
;
2350 st2
= (gfc_symtree
*) _st2
;
2352 return strcmp (st1
->name
, st2
->name
);
2356 /* Allocate a new symtree node and associate it with the new symbol. */
2359 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2363 st
= XCNEW (gfc_symtree
);
2364 st
->name
= gfc_get_string (name
);
2366 gfc_insert_bbt (root
, st
, compare_symtree
);
2371 /* Delete a symbol from the tree. Does not free the symbol itself! */
2374 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2376 gfc_symtree st
, *st0
;
2378 st0
= gfc_find_symtree (*root
, name
);
2380 st
.name
= gfc_get_string (name
);
2381 gfc_delete_bbt (root
, &st
, compare_symtree
);
2387 /* Given a root symtree node and a name, try to find the symbol within
2388 the namespace. Returns NULL if the symbol is not found. */
2391 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2397 c
= strcmp (name
, st
->name
);
2401 st
= (c
< 0) ? st
->left
: st
->right
;
2408 /* Return a symtree node with a name that is guaranteed to be unique
2409 within the namespace and corresponds to an illegal fortran name. */
2412 gfc_get_unique_symtree (gfc_namespace
*ns
)
2414 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2415 static int serial
= 0;
2417 sprintf (name
, "@%d", serial
++);
2418 return gfc_new_symtree (&ns
->sym_root
, name
);
2422 /* Given a name find a user operator node, creating it if it doesn't
2423 exist. These are much simpler than symbols because they can't be
2424 ambiguous with one another. */
2427 gfc_get_uop (const char *name
)
2432 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2436 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2438 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2439 uop
->name
= gfc_get_string (name
);
2440 uop
->access
= ACCESS_UNKNOWN
;
2441 uop
->ns
= gfc_current_ns
;
2447 /* Given a name find the user operator node. Returns NULL if it does
2451 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2456 ns
= gfc_current_ns
;
2458 st
= gfc_find_symtree (ns
->uop_root
, name
);
2459 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2463 /* Remove a gfc_symbol structure and everything it points to. */
2466 gfc_free_symbol (gfc_symbol
*sym
)
2472 gfc_free_array_spec (sym
->as
);
2474 free_components (sym
->components
);
2476 gfc_free_expr (sym
->value
);
2478 gfc_free_namelist (sym
->namelist
);
2480 gfc_free_namespace (sym
->formal_ns
);
2482 if (!sym
->attr
.generic_copy
)
2483 gfc_free_interface (sym
->generic
);
2485 gfc_free_formal_arglist (sym
->formal
);
2487 gfc_free_namespace (sym
->f2k_derived
);
2493 /* Decrease the reference counter and free memory when we reach zero. */
2496 gfc_release_symbol (gfc_symbol
*sym
)
2501 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2)
2503 /* As formal_ns contains a reference to sym, delete formal_ns just
2504 before the deletion of sym. */
2505 gfc_namespace
*ns
= sym
->formal_ns
;
2506 sym
->formal_ns
= NULL
;
2507 gfc_free_namespace (ns
);
2514 gcc_assert (sym
->refs
== 0);
2515 gfc_free_symbol (sym
);
2519 /* Allocate and initialize a new symbol node. */
2522 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2526 p
= XCNEW (gfc_symbol
);
2528 gfc_clear_ts (&p
->ts
);
2529 gfc_clear_attr (&p
->attr
);
2532 p
->declared_at
= gfc_current_locus
;
2534 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2535 gfc_internal_error ("new_symbol(): Symbol name too long");
2537 p
->name
= gfc_get_string (name
);
2539 /* Make sure flags for symbol being C bound are clear initially. */
2540 p
->attr
.is_bind_c
= 0;
2541 p
->attr
.is_iso_c
= 0;
2542 /* Make sure the binding label field has a Nul char to start. */
2543 p
->binding_label
[0] = '\0';
2545 /* Clear the ptrs we may need. */
2546 p
->common_block
= NULL
;
2547 p
->f2k_derived
= NULL
;
2554 /* Generate an error if a symbol is ambiguous. */
2557 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2560 if (st
->n
.sym
->module
)
2561 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2562 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2564 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2565 "from current program unit", name
, st
->n
.sym
->name
);
2569 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2570 selector on the stack. If yes, replace it by the corresponding temporary. */
2573 select_type_insert_tmp (gfc_symtree
**st
)
2575 gfc_select_type_stack
*stack
= select_type_stack
;
2576 for (; stack
; stack
= stack
->prev
)
2577 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2582 /* Look for a symtree in the current procedure -- that is, go up to
2583 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2586 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
2590 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
2594 if (!ns
->construct_entities
)
2603 /* Search for a symtree starting in the current namespace, resorting to
2604 any parent namespaces if requested by a nonzero parent_flag.
2605 Returns nonzero if the name is ambiguous. */
2608 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2609 gfc_symtree
**result
)
2614 ns
= gfc_current_ns
;
2618 st
= gfc_find_symtree (ns
->sym_root
, name
);
2621 select_type_insert_tmp (&st
);
2624 /* Ambiguous generic interfaces are permitted, as long
2625 as the specific interfaces are different. */
2626 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2628 ambiguous_symbol (name
, st
);
2647 /* Same, but returns the symbol instead. */
2650 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2651 gfc_symbol
**result
)
2656 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2661 *result
= st
->n
.sym
;
2667 /* Save symbol with the information necessary to back it out. */
2670 save_symbol_data (gfc_symbol
*sym
)
2673 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2676 sym
->old_symbol
= XCNEW (gfc_symbol
);
2677 *(sym
->old_symbol
) = *sym
;
2679 sym
->tlink
= changed_syms
;
2684 /* Given a name, find a symbol, or create it if it does not exist yet
2685 in the current namespace. If the symbol is found we make sure that
2688 The integer return code indicates
2690 1 The symbol name was ambiguous
2691 2 The name meant to be established was already host associated.
2693 So if the return value is nonzero, then an error was issued. */
2696 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2697 bool allow_subroutine
)
2702 /* This doesn't usually happen during resolution. */
2704 ns
= gfc_current_ns
;
2706 /* Try to find the symbol in ns. */
2707 st
= gfc_find_symtree (ns
->sym_root
, name
);
2711 /* If not there, create a new symbol. */
2712 p
= gfc_new_symbol (name
, ns
);
2714 /* Add to the list of tentative symbols. */
2715 p
->old_symbol
= NULL
;
2716 p
->tlink
= changed_syms
;
2721 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2728 /* Make sure the existing symbol is OK. Ambiguous
2729 generic interfaces are permitted, as long as the
2730 specific interfaces are different. */
2731 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2733 ambiguous_symbol (name
, st
);
2738 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2739 && !(allow_subroutine
&& p
->attr
.subroutine
)
2740 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2741 && (ns
->has_import_set
|| p
->attr
.imported
)))
2743 /* Symbol is from another namespace. */
2744 gfc_error ("Symbol '%s' at %C has already been host associated",
2751 /* Copy in case this symbol is changed. */
2752 save_symbol_data (p
);
2761 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2766 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2771 *result
= st
->n
.sym
;
2778 /* Subroutine that searches for a symbol, creating it if it doesn't
2779 exist, but tries to host-associate the symbol if possible. */
2782 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2787 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2791 save_symbol_data (st
->n
.sym
);
2796 if (gfc_current_ns
->parent
!= NULL
)
2798 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2809 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2814 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2819 i
= gfc_get_ha_sym_tree (name
, &st
);
2822 *result
= st
->n
.sym
;
2829 /* Undoes all the changes made to symbols in the current statement.
2830 This subroutine is made simpler due to the fact that attributes are
2831 never removed once added. */
2834 gfc_undo_symbols (void)
2836 gfc_symbol
*p
, *q
, *old
;
2837 tentative_tbp
*tbp
, *tbq
;
2839 for (p
= changed_syms
; p
; p
= q
)
2845 /* Symbol was new. */
2846 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
2848 /* If the symbol was added to any common block, it
2849 needs to be removed to stop the resolver looking
2850 for a (possibly) dead symbol. */
2852 if (p
->common_block
->head
== p
)
2853 p
->common_block
->head
= p
->common_next
;
2856 gfc_symbol
*cparent
, *csym
;
2858 cparent
= p
->common_block
->head
;
2859 csym
= cparent
->common_next
;
2864 csym
= csym
->common_next
;
2867 gcc_assert(cparent
->common_next
== p
);
2869 cparent
->common_next
= csym
->common_next
;
2873 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2875 gfc_release_symbol (p
);
2879 /* Restore previous state of symbol. Just copy simple stuff. */
2881 old
= p
->old_symbol
;
2883 p
->ts
.type
= old
->ts
.type
;
2884 p
->ts
.kind
= old
->ts
.kind
;
2886 p
->attr
= old
->attr
;
2888 if (p
->value
!= old
->value
)
2890 gfc_free_expr (old
->value
);
2894 if (p
->as
!= old
->as
)
2897 gfc_free_array_spec (p
->as
);
2901 p
->generic
= old
->generic
;
2902 p
->component_access
= old
->component_access
;
2904 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2906 gfc_free_namelist (p
->namelist
);
2911 if (p
->namelist_tail
!= old
->namelist_tail
)
2913 gfc_free_namelist (old
->namelist_tail
);
2914 old
->namelist_tail
->next
= NULL
;
2918 p
->namelist_tail
= old
->namelist_tail
;
2920 if (p
->formal
!= old
->formal
)
2922 gfc_free_formal_arglist (p
->formal
);
2923 p
->formal
= old
->formal
;
2926 free (p
->old_symbol
);
2927 p
->old_symbol
= NULL
;
2931 changed_syms
= NULL
;
2933 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2936 /* Procedure is already marked `error' by default. */
2939 tentative_tbp_list
= NULL
;
2943 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2944 components of old_symbol that might need deallocation are the "allocatables"
2945 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2946 namelist_tail. In case these differ between old_symbol and sym, it's just
2947 because sym->namelist has gotten a few more items. */
2950 free_old_symbol (gfc_symbol
*sym
)
2953 if (sym
->old_symbol
== NULL
)
2956 if (sym
->old_symbol
->as
!= sym
->as
)
2957 gfc_free_array_spec (sym
->old_symbol
->as
);
2959 if (sym
->old_symbol
->value
!= sym
->value
)
2960 gfc_free_expr (sym
->old_symbol
->value
);
2962 if (sym
->old_symbol
->formal
!= sym
->formal
)
2963 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2965 free (sym
->old_symbol
);
2966 sym
->old_symbol
= NULL
;
2970 /* Makes the changes made in the current statement permanent-- gets
2971 rid of undo information. */
2974 gfc_commit_symbols (void)
2977 tentative_tbp
*tbp
, *tbq
;
2979 for (p
= changed_syms
; p
; p
= q
)
2985 free_old_symbol (p
);
2987 changed_syms
= NULL
;
2989 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2992 tbp
->proc
->error
= 0;
2995 tentative_tbp_list
= NULL
;
2999 /* Makes the changes made in one symbol permanent -- gets rid of undo
3003 gfc_commit_symbol (gfc_symbol
*sym
)
3007 if (changed_syms
== sym
)
3008 changed_syms
= sym
->tlink
;
3011 for (p
= changed_syms
; p
; p
= p
->tlink
)
3012 if (p
->tlink
== sym
)
3014 p
->tlink
= sym
->tlink
;
3023 free_old_symbol (sym
);
3027 /* Recursively free trees containing type-bound procedures. */
3030 free_tb_tree (gfc_symtree
*t
)
3035 free_tb_tree (t
->left
);
3036 free_tb_tree (t
->right
);
3038 /* TODO: Free type-bound procedure structs themselves; probably needs some
3039 sort of ref-counting mechanism. */
3045 /* Recursive function that deletes an entire tree and all the common
3046 head structures it points to. */
3049 free_common_tree (gfc_symtree
* common_tree
)
3051 if (common_tree
== NULL
)
3054 free_common_tree (common_tree
->left
);
3055 free_common_tree (common_tree
->right
);
3061 /* Recursive function that deletes an entire tree and all the user
3062 operator nodes that it contains. */
3065 free_uop_tree (gfc_symtree
*uop_tree
)
3067 if (uop_tree
== NULL
)
3070 free_uop_tree (uop_tree
->left
);
3071 free_uop_tree (uop_tree
->right
);
3073 gfc_free_interface (uop_tree
->n
.uop
->op
);
3074 free (uop_tree
->n
.uop
);
3079 /* Recursive function that deletes an entire tree and all the symbols
3080 that it contains. */
3083 free_sym_tree (gfc_symtree
*sym_tree
)
3085 if (sym_tree
== NULL
)
3088 free_sym_tree (sym_tree
->left
);
3089 free_sym_tree (sym_tree
->right
);
3091 gfc_release_symbol (sym_tree
->n
.sym
);
3096 /* Free the derived type list. */
3099 gfc_free_dt_list (void)
3101 gfc_dt_list
*dt
, *n
;
3103 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3109 gfc_derived_types
= NULL
;
3113 /* Free the gfc_equiv_info's. */
3116 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3120 gfc_free_equiv_infos (s
->next
);
3125 /* Free the gfc_equiv_lists. */
3128 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3132 gfc_free_equiv_lists (l
->next
);
3133 gfc_free_equiv_infos (l
->equiv
);
3138 /* Free a finalizer procedure list. */
3141 gfc_free_finalizer (gfc_finalizer
* el
)
3145 gfc_release_symbol (el
->proc_sym
);
3151 gfc_free_finalizer_list (gfc_finalizer
* list
)
3155 gfc_finalizer
* current
= list
;
3157 gfc_free_finalizer (current
);
3162 /* Create a new gfc_charlen structure and add it to a namespace.
3163 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3166 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3169 cl
= gfc_get_charlen ();
3174 /* Put into namespace, but don't allow reject_statement
3175 to free it if old_cl is given. */
3176 gfc_charlen
**prev
= &ns
->cl_list
;
3177 cl
->next
= ns
->old_cl_list
;
3178 while (*prev
!= ns
->old_cl_list
)
3179 prev
= &(*prev
)->next
;
3181 ns
->old_cl_list
= cl
;
3182 cl
->length
= gfc_copy_expr (old_cl
->length
);
3183 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3184 cl
->backend_decl
= old_cl
->backend_decl
;
3185 cl
->passed_length
= old_cl
->passed_length
;
3186 cl
->resolved
= old_cl
->resolved
;
3190 /* Put into namespace. */
3191 cl
->next
= ns
->cl_list
;
3199 /* Free the charlen list from cl to end (end is not freed).
3200 Free the whole list if end is NULL. */
3202 void gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3206 for (; cl
!= end
; cl
= cl2
)
3211 gfc_free_expr (cl
->length
);
3217 /* Free entry list structs. */
3220 free_entry_list (gfc_entry_list
*el
)
3222 gfc_entry_list
*next
;
3229 free_entry_list (next
);
3233 /* Free a namespace structure and everything below it. Interface
3234 lists associated with intrinsic operators are not freed. These are
3235 taken care of when a specific name is freed. */
3238 gfc_free_namespace (gfc_namespace
*ns
)
3240 gfc_namespace
*p
, *q
;
3249 gcc_assert (ns
->refs
== 0);
3251 gfc_free_statements (ns
->code
);
3253 free_sym_tree (ns
->sym_root
);
3254 free_uop_tree (ns
->uop_root
);
3255 free_common_tree (ns
->common_root
);
3256 free_tb_tree (ns
->tb_sym_root
);
3257 free_tb_tree (ns
->tb_uop_root
);
3258 gfc_free_finalizer_list (ns
->finalizers
);
3259 gfc_free_charlen (ns
->cl_list
, NULL
);
3260 free_st_labels (ns
->st_labels
);
3262 free_entry_list (ns
->entries
);
3263 gfc_free_equiv (ns
->equiv
);
3264 gfc_free_equiv_lists (ns
->equiv_lists
);
3265 gfc_free_use_stmts (ns
->use_stmts
);
3267 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3268 gfc_free_interface (ns
->op
[i
]);
3270 gfc_free_data (ns
->data
);
3274 /* Recursively free any contained namespaces. */
3279 gfc_free_namespace (q
);
3285 gfc_symbol_init_2 (void)
3288 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3293 gfc_symbol_done_2 (void)
3296 gfc_free_namespace (gfc_current_ns
);
3297 gfc_current_ns
= NULL
;
3298 gfc_free_dt_list ();
3302 /* Clear mark bits from symbol nodes associated with a symtree node. */
3305 clear_sym_mark (gfc_symtree
*st
)
3308 st
->n
.sym
->mark
= 0;
3312 /* Recursively traverse the symtree nodes. */
3315 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
3320 gfc_traverse_symtree (st
->left
, func
);
3322 gfc_traverse_symtree (st
->right
, func
);
3326 /* Recursive namespace traversal function. */
3329 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
3335 traverse_ns (st
->left
, func
);
3337 if (st
->n
.sym
->mark
== 0)
3338 (*func
) (st
->n
.sym
);
3339 st
->n
.sym
->mark
= 1;
3341 traverse_ns (st
->right
, func
);
3345 /* Call a given function for all symbols in the namespace. We take
3346 care that each gfc_symbol node is called exactly once. */
3349 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3352 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3354 traverse_ns (ns
->sym_root
, func
);
3358 /* Return TRUE when name is the name of an intrinsic type. */
3361 gfc_is_intrinsic_typename (const char *name
)
3363 if (strcmp (name
, "integer") == 0
3364 || strcmp (name
, "real") == 0
3365 || strcmp (name
, "character") == 0
3366 || strcmp (name
, "logical") == 0
3367 || strcmp (name
, "complex") == 0
3368 || strcmp (name
, "doubleprecision") == 0
3369 || strcmp (name
, "doublecomplex") == 0)
3376 /* Return TRUE if the symbol is an automatic variable. */
3379 gfc_is_var_automatic (gfc_symbol
*sym
)
3381 /* Pointer and allocatable variables are never automatic. */
3382 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3384 /* Check for arrays with non-constant size. */
3385 if (sym
->attr
.dimension
&& sym
->as
3386 && !gfc_is_compile_time_shape (sym
->as
))
3388 /* Check for non-constant length character variables. */
3389 if (sym
->ts
.type
== BT_CHARACTER
3391 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3396 /* Given a symbol, mark it as SAVEd if it is allowed. */
3399 save_symbol (gfc_symbol
*sym
)
3402 if (sym
->attr
.use_assoc
)
3405 if (sym
->attr
.in_common
3408 || sym
->attr
.flavor
!= FL_VARIABLE
)
3410 /* Automatic objects are not saved. */
3411 if (gfc_is_var_automatic (sym
))
3413 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
3417 /* Mark those symbols which can be SAVEd as such. */
3420 gfc_save_all (gfc_namespace
*ns
)
3422 gfc_traverse_ns (ns
, save_symbol
);
3426 /* Make sure that no changes to symbols are pending. */
3429 gfc_enforce_clean_symbol_state(void)
3431 gcc_assert (changed_syms
== NULL
);
3435 /************** Global symbol handling ************/
3438 /* Search a tree for the global symbol. */
3441 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3450 c
= strcmp (name
, symbol
->name
);
3454 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3461 /* Compare two global symbols. Used for managing the BB tree. */
3464 gsym_compare (void *_s1
, void *_s2
)
3466 gfc_gsymbol
*s1
, *s2
;
3468 s1
= (gfc_gsymbol
*) _s1
;
3469 s2
= (gfc_gsymbol
*) _s2
;
3470 return strcmp (s1
->name
, s2
->name
);
3474 /* Get a global symbol, creating it if it doesn't exist. */
3477 gfc_get_gsymbol (const char *name
)
3481 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3485 s
= XCNEW (gfc_gsymbol
);
3486 s
->type
= GSYM_UNKNOWN
;
3487 s
->name
= gfc_get_string (name
);
3489 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3496 get_iso_c_binding_dt (int sym_id
)
3498 gfc_dt_list
*dt_list
;
3500 dt_list
= gfc_derived_types
;
3502 /* Loop through the derived types in the name list, searching for
3503 the desired symbol from iso_c_binding. Search the parent namespaces
3504 if necessary and requested to (parent_flag). */
3505 while (dt_list
!= NULL
)
3507 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3508 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3509 return dt_list
->derived
;
3511 dt_list
= dt_list
->next
;
3518 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3519 with C. This is necessary for any derived type that is BIND(C) and for
3520 derived types that are parameters to functions that are BIND(C). All
3521 fields of the derived type are required to be interoperable, and are tested
3522 for such. If an error occurs, the errors are reported here, allowing for
3523 multiple errors to be handled for a single derived type. */
3526 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3528 gfc_component
*curr_comp
= NULL
;
3529 gfc_try is_c_interop
= FAILURE
;
3530 gfc_try retval
= SUCCESS
;
3532 if (derived_sym
== NULL
)
3533 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3534 "unexpectedly NULL");
3536 /* If we've already looked at this derived symbol, do not look at it again
3537 so we don't repeat warnings/errors. */
3538 if (derived_sym
->ts
.is_c_interop
)
3541 /* The derived type must have the BIND attribute to be interoperable
3542 J3/04-007, Section 15.2.3. */
3543 if (derived_sym
->attr
.is_bind_c
!= 1)
3545 derived_sym
->ts
.is_c_interop
= 0;
3546 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3547 "attribute to be C interoperable", derived_sym
->name
,
3548 &(derived_sym
->declared_at
));
3552 curr_comp
= derived_sym
->components
;
3554 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3555 empty struct. Section 15.2 in Fortran 2003 states: "The following
3556 subclauses define the conditions under which a Fortran entity is
3557 interoperable. If a Fortran entity is interoperable, an equivalent
3558 entity may be defined by means of C and the Fortran entity is said
3559 to be interoperable with the C entity. There does not have to be such
3560 an interoperating C entity."
3562 if (curr_comp
== NULL
)
3564 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3565 "and may be inaccessible by the C companion processor",
3566 derived_sym
->name
, &(derived_sym
->declared_at
));
3567 derived_sym
->ts
.is_c_interop
= 1;
3568 derived_sym
->attr
.is_bind_c
= 1;
3573 /* Initialize the derived type as being C interoperable.
3574 If we find an error in the components, this will be set false. */
3575 derived_sym
->ts
.is_c_interop
= 1;
3577 /* Loop through the list of components to verify that the kind of
3578 each is a C interoperable type. */
3581 /* The components cannot be pointers (fortran sense).
3582 J3/04-007, Section 15.2.3, C1505. */
3583 if (curr_comp
->attr
.pointer
!= 0)
3585 gfc_error ("Component '%s' at %L cannot have the "
3586 "POINTER attribute because it is a member "
3587 "of the BIND(C) derived type '%s' at %L",
3588 curr_comp
->name
, &(curr_comp
->loc
),
3589 derived_sym
->name
, &(derived_sym
->declared_at
));
3593 if (curr_comp
->attr
.proc_pointer
!= 0)
3595 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3596 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3597 &curr_comp
->loc
, derived_sym
->name
,
3598 &derived_sym
->declared_at
);
3602 /* The components cannot be allocatable.
3603 J3/04-007, Section 15.2.3, C1505. */
3604 if (curr_comp
->attr
.allocatable
!= 0)
3606 gfc_error ("Component '%s' at %L cannot have the "
3607 "ALLOCATABLE attribute because it is a member "
3608 "of the BIND(C) derived type '%s' at %L",
3609 curr_comp
->name
, &(curr_comp
->loc
),
3610 derived_sym
->name
, &(derived_sym
->declared_at
));
3614 /* BIND(C) derived types must have interoperable components. */
3615 if (curr_comp
->ts
.type
== BT_DERIVED
3616 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3617 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3619 /* This should be allowed; the draft says a derived-type can not
3620 have type parameters if it is has the BIND attribute. Type
3621 parameters seem to be for making parameterized derived types.
3622 There's no need to verify the type if it is c_ptr/c_funptr. */
3623 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3627 /* Grab the typespec for the given component and test the kind. */
3628 is_c_interop
= verify_c_interop (&(curr_comp
->ts
));
3630 if (is_c_interop
!= SUCCESS
)
3632 /* Report warning and continue since not fatal. The
3633 draft does specify a constraint that requires all fields
3634 to interoperate, but if the user says real(4), etc., it
3635 may interoperate with *something* in C, but the compiler
3636 most likely won't know exactly what. Further, it may not
3637 interoperate with the same data type(s) in C if the user
3638 recompiles with different flags (e.g., -m32 and -m64 on
3639 x86_64 and using integer(4) to claim interop with a
3641 if (derived_sym
->attr
.is_bind_c
== 1)
3642 /* If the derived type is bind(c), all fields must be
3644 gfc_warning ("Component '%s' in derived type '%s' at %L "
3645 "may not be C interoperable, even though "
3646 "derived type '%s' is BIND(C)",
3647 curr_comp
->name
, derived_sym
->name
,
3648 &(curr_comp
->loc
), derived_sym
->name
);
3650 /* If derived type is param to bind(c) routine, or to one
3651 of the iso_c_binding procs, it must be interoperable, so
3652 all fields must interop too. */
3653 gfc_warning ("Component '%s' in derived type '%s' at %L "
3654 "may not be C interoperable",
3655 curr_comp
->name
, derived_sym
->name
,
3660 curr_comp
= curr_comp
->next
;
3661 } while (curr_comp
!= NULL
);
3664 /* Make sure we don't have conflicts with the attributes. */
3665 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3667 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3668 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3669 &(derived_sym
->declared_at
));
3673 if (derived_sym
->attr
.sequence
!= 0)
3675 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3676 "attribute because it is BIND(C)", derived_sym
->name
,
3677 &(derived_sym
->declared_at
));
3681 /* Mark the derived type as not being C interoperable if we found an
3682 error. If there were only warnings, proceed with the assumption
3683 it's interoperable. */
3684 if (retval
== FAILURE
)
3685 derived_sym
->ts
.is_c_interop
= 0;
3691 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3694 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3695 const char *module_name
)
3697 gfc_symtree
*tmp_symtree
;
3698 gfc_symbol
*tmp_sym
;
3701 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3703 if (tmp_symtree
!= NULL
)
3704 tmp_sym
= tmp_symtree
->n
.sym
;
3708 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3709 "create symbol for %s", ptr_name
);
3712 /* Set up the symbol's important fields. Save attr required so we can
3713 initialize the ptr to NULL. */
3714 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3715 tmp_sym
->ts
.is_c_interop
= 1;
3716 tmp_sym
->attr
.is_c_interop
= 1;
3717 tmp_sym
->ts
.is_iso_c
= 1;
3718 tmp_sym
->ts
.type
= BT_DERIVED
;
3720 /* The c_ptr and c_funptr derived types will provide the
3721 definition for c_null_ptr and c_null_funptr, respectively. */
3722 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3723 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3725 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3726 if (tmp_sym
->ts
.u
.derived
== NULL
)
3728 /* This can occur if the user forgot to declare c_ptr or
3729 c_funptr and they're trying to use one of the procedures
3730 that has arg(s) of the missing type. In this case, a
3731 regular version of the thing should have been put in the
3733 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3734 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3735 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3736 ? "_gfortran_iso_c_binding_c_ptr"
3737 : "_gfortran_iso_c_binding_c_funptr"));
3739 tmp_sym
->ts
.u
.derived
=
3740 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3741 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3744 /* Module name is some mangled version of iso_c_binding. */
3745 tmp_sym
->module
= gfc_get_string (module_name
);
3747 /* Say it's from the iso_c_binding module. */
3748 tmp_sym
->attr
.is_iso_c
= 1;
3750 tmp_sym
->attr
.use_assoc
= 1;
3751 tmp_sym
->attr
.is_bind_c
= 1;
3752 /* Set the binding_label. */
3753 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3755 /* Set the c_address field of c_null_ptr and c_null_funptr to
3756 the value of NULL. */
3757 tmp_sym
->value
= gfc_get_expr ();
3758 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3759 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3760 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
3761 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
3762 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
3763 c
->expr
= gfc_get_expr ();
3764 c
->expr
->expr_type
= EXPR_NULL
;
3765 c
->expr
->ts
.is_iso_c
= 1;
3766 /* Must declare c_null_ptr and c_null_funptr as having the
3767 PARAMETER attribute so they can be used in init expressions. */
3768 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3774 /* Add a formal argument, gfc_formal_arglist, to the
3775 end of the given list of arguments. Set the reference to the
3776 provided symbol, param_sym, in the argument. */
3779 add_formal_arg (gfc_formal_arglist
**head
,
3780 gfc_formal_arglist
**tail
,
3781 gfc_formal_arglist
*formal_arg
,
3782 gfc_symbol
*param_sym
)
3784 /* Put in list, either as first arg or at the tail (curr arg). */
3786 *head
= *tail
= formal_arg
;
3789 (*tail
)->next
= formal_arg
;
3790 (*tail
) = formal_arg
;
3793 (*tail
)->sym
= param_sym
;
3794 (*tail
)->next
= NULL
;
3800 /* Generates a symbol representing the CPTR argument to an
3801 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3802 CPTR and add it to the provided argument list. */
3805 gen_cptr_param (gfc_formal_arglist
**head
,
3806 gfc_formal_arglist
**tail
,
3807 const char *module_name
,
3808 gfc_namespace
*ns
, const char *c_ptr_name
,
3811 gfc_symbol
*param_sym
= NULL
;
3812 gfc_symbol
*c_ptr_sym
= NULL
;
3813 gfc_symtree
*param_symtree
= NULL
;
3814 gfc_formal_arglist
*formal_arg
= NULL
;
3815 const char *c_ptr_in
;
3816 const char *c_ptr_type
= NULL
;
3818 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3819 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3821 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3823 if(c_ptr_name
== NULL
)
3824 c_ptr_in
= "gfc_cptr__";
3826 c_ptr_in
= c_ptr_name
;
3827 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
, false);
3828 if (param_symtree
!= NULL
)
3829 param_sym
= param_symtree
->n
.sym
;
3831 gfc_internal_error ("gen_cptr_param(): Unable to "
3832 "create symbol for %s", c_ptr_in
);
3834 /* Set up the appropriate fields for the new c_ptr param sym. */
3836 param_sym
->attr
.flavor
= FL_DERIVED
;
3837 param_sym
->ts
.type
= BT_DERIVED
;
3838 param_sym
->attr
.intent
= INTENT_IN
;
3839 param_sym
->attr
.dummy
= 1;
3841 /* This will pass the ptr to the iso_c routines as a (void *). */
3842 param_sym
->attr
.value
= 1;
3843 param_sym
->attr
.use_assoc
= 1;
3845 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3847 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3848 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3850 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3851 if (c_ptr_sym
== NULL
)
3853 /* This can happen if the user did not define c_ptr but they are
3854 trying to use one of the iso_c_binding functions that need it. */
3855 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3856 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3857 (const char *)c_ptr_type
);
3859 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3860 (const char *)c_ptr_type
);
3862 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3865 param_sym
->ts
.u
.derived
= c_ptr_sym
;
3866 param_sym
->module
= gfc_get_string (module_name
);
3868 /* Make new formal arg. */
3869 formal_arg
= gfc_get_formal_arglist ();
3870 /* Add arg to list of formal args (the CPTR arg). */
3871 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3873 /* Validate changes. */
3874 gfc_commit_symbol (param_sym
);
3878 /* Generates a symbol representing the FPTR argument to an
3879 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3880 FPTR and add it to the provided argument list. */
3883 gen_fptr_param (gfc_formal_arglist
**head
,
3884 gfc_formal_arglist
**tail
,
3885 const char *module_name
,
3886 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3888 gfc_symbol
*param_sym
= NULL
;
3889 gfc_symtree
*param_symtree
= NULL
;
3890 gfc_formal_arglist
*formal_arg
= NULL
;
3891 const char *f_ptr_out
= "gfc_fptr__";
3893 if (f_ptr_name
!= NULL
)
3894 f_ptr_out
= f_ptr_name
;
3896 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
, false);
3897 if (param_symtree
!= NULL
)
3898 param_sym
= param_symtree
->n
.sym
;
3900 gfc_internal_error ("generateFPtrParam(): Unable to "
3901 "create symbol for %s", f_ptr_out
);
3903 /* Set up the necessary fields for the fptr output param sym. */
3906 param_sym
->attr
.proc_pointer
= 1;
3908 param_sym
->attr
.pointer
= 1;
3909 param_sym
->attr
.dummy
= 1;
3910 param_sym
->attr
.use_assoc
= 1;
3912 /* ISO C Binding type to allow any pointer type as actual param. */
3913 param_sym
->ts
.type
= BT_VOID
;
3914 param_sym
->module
= gfc_get_string (module_name
);
3917 formal_arg
= gfc_get_formal_arglist ();
3918 /* Add arg to list of formal args. */
3919 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3921 /* Validate changes. */
3922 gfc_commit_symbol (param_sym
);
3926 /* Generates a symbol representing the optional SHAPE argument for the
3927 iso_c_binding c_f_pointer() procedure. Also, create a
3928 gfc_formal_arglist for the SHAPE and add it to the provided
3932 gen_shape_param (gfc_formal_arglist
**head
,
3933 gfc_formal_arglist
**tail
,
3934 const char *module_name
,
3935 gfc_namespace
*ns
, const char *shape_param_name
)
3937 gfc_symbol
*param_sym
= NULL
;
3938 gfc_symtree
*param_symtree
= NULL
;
3939 gfc_formal_arglist
*formal_arg
= NULL
;
3940 const char *shape_param
= "gfc_shape_array__";
3942 if (shape_param_name
!= NULL
)
3943 shape_param
= shape_param_name
;
3945 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
, false);
3946 if (param_symtree
!= NULL
)
3947 param_sym
= param_symtree
->n
.sym
;
3949 gfc_internal_error ("generateShapeParam(): Unable to "
3950 "create symbol for %s", shape_param
);
3952 /* Set up the necessary fields for the shape input param sym. */
3954 param_sym
->attr
.dummy
= 1;
3955 param_sym
->attr
.use_assoc
= 1;
3957 /* Integer array, rank 1, describing the shape of the object. Make it's
3958 type BT_VOID initially so we can accept any type/kind combination of
3959 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3960 of BT_INTEGER type. */
3961 param_sym
->ts
.type
= BT_VOID
;
3963 /* Initialize the kind to default integer. However, it will be overridden
3964 during resolution to match the kind of the SHAPE parameter given as
3965 the actual argument (to allow for any valid integer kind). */
3966 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3967 param_sym
->as
= gfc_get_array_spec ();
3969 param_sym
->as
->rank
= 1;
3970 param_sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
3973 /* The extent is unknown until we get it. The length give us
3974 the rank the incoming pointer. */
3975 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3977 /* The arg is also optional; it is required iff the second arg
3978 (fptr) is to an array, otherwise, it's ignored. */
3979 param_sym
->attr
.optional
= 1;
3980 param_sym
->attr
.intent
= INTENT_IN
;
3981 param_sym
->attr
.dimension
= 1;
3982 param_sym
->module
= gfc_get_string (module_name
);
3985 formal_arg
= gfc_get_formal_arglist ();
3986 /* Add arg to list of formal args. */
3987 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3989 /* Validate changes. */
3990 gfc_commit_symbol (param_sym
);
3994 /* Add a procedure interface to the given symbol (i.e., store a
3995 reference to the list of formal arguments). */
3998 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3999 gfc_formal_arglist
*formal
)
4002 sym
->formal
= formal
;
4003 sym
->attr
.if_source
= source
;
4007 /* Copy the formal args from an existing symbol, src, into a new
4008 symbol, dest. New formal args are created, and the description of
4009 each arg is set according to the existing ones. This function is
4010 used when creating procedure declaration variables from a procedure
4011 declaration statement (see match_proc_decl()) to create the formal
4012 args based on the args of a given named interface. */
4015 gfc_copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
4017 gfc_formal_arglist
*head
= NULL
;
4018 gfc_formal_arglist
*tail
= NULL
;
4019 gfc_formal_arglist
*formal_arg
= NULL
;
4020 gfc_formal_arglist
*curr_arg
= NULL
;
4021 gfc_formal_arglist
*formal_prev
= NULL
;
4022 /* Save current namespace so we can change it for formal args. */
4023 gfc_namespace
*parent_ns
= gfc_current_ns
;
4025 /* Create a new namespace, which will be the formal ns (namespace
4026 of the formal args). */
4027 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4028 gfc_current_ns
->proc_name
= dest
;
4030 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4032 formal_arg
= gfc_get_formal_arglist ();
4033 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4035 /* May need to copy more info for the symbol. */
4036 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4037 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4038 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4039 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4041 /* If this isn't the first arg, set up the next ptr. For the
4042 last arg built, the formal_arg->next will never get set to
4043 anything other than NULL. */
4044 if (formal_prev
!= NULL
)
4045 formal_prev
->next
= formal_arg
;
4047 formal_arg
->next
= NULL
;
4049 formal_prev
= formal_arg
;
4051 /* Add arg to list of formal args. */
4052 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4054 /* Validate changes. */
4055 gfc_commit_symbol (formal_arg
->sym
);
4058 /* Add the interface to the symbol. */
4059 add_proc_interface (dest
, IFSRC_DECL
, head
);
4061 /* Store the formal namespace information. */
4062 if (dest
->formal
!= NULL
)
4063 /* The current ns should be that for the dest proc. */
4064 dest
->formal_ns
= gfc_current_ns
;
4065 /* Restore the current namespace to what it was on entry. */
4066 gfc_current_ns
= parent_ns
;
4071 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
4073 gfc_formal_arglist
*head
= NULL
;
4074 gfc_formal_arglist
*tail
= NULL
;
4075 gfc_formal_arglist
*formal_arg
= NULL
;
4076 gfc_intrinsic_arg
*curr_arg
= NULL
;
4077 gfc_formal_arglist
*formal_prev
= NULL
;
4078 /* Save current namespace so we can change it for formal args. */
4079 gfc_namespace
*parent_ns
= gfc_current_ns
;
4081 /* Create a new namespace, which will be the formal ns (namespace
4082 of the formal args). */
4083 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4084 gfc_current_ns
->proc_name
= dest
;
4086 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4088 formal_arg
= gfc_get_formal_arglist ();
4089 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4091 /* May need to copy more info for the symbol. */
4092 formal_arg
->sym
->ts
= curr_arg
->ts
;
4093 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4094 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4095 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4096 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4097 formal_arg
->sym
->attr
.dummy
= 1;
4099 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4100 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4102 /* If this isn't the first arg, set up the next ptr. For the
4103 last arg built, the formal_arg->next will never get set to
4104 anything other than NULL. */
4105 if (formal_prev
!= NULL
)
4106 formal_prev
->next
= formal_arg
;
4108 formal_arg
->next
= NULL
;
4110 formal_prev
= formal_arg
;
4112 /* Add arg to list of formal args. */
4113 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4115 /* Validate changes. */
4116 gfc_commit_symbol (formal_arg
->sym
);
4119 /* Add the interface to the symbol. */
4120 add_proc_interface (dest
, IFSRC_DECL
, head
);
4122 /* Store the formal namespace information. */
4123 if (dest
->formal
!= NULL
)
4124 /* The current ns should be that for the dest proc. */
4125 dest
->formal_ns
= gfc_current_ns
;
4126 /* Restore the current namespace to what it was on entry. */
4127 gfc_current_ns
= parent_ns
;
4132 gfc_copy_formal_args_ppc (gfc_component
*dest
, gfc_symbol
*src
)
4134 gfc_formal_arglist
*head
= NULL
;
4135 gfc_formal_arglist
*tail
= NULL
;
4136 gfc_formal_arglist
*formal_arg
= NULL
;
4137 gfc_formal_arglist
*curr_arg
= NULL
;
4138 gfc_formal_arglist
*formal_prev
= NULL
;
4139 /* Save current namespace so we can change it for formal args. */
4140 gfc_namespace
*parent_ns
= gfc_current_ns
;
4142 /* Create a new namespace, which will be the formal ns (namespace
4143 of the formal args). */
4144 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4145 /* TODO: gfc_current_ns->proc_name = dest;*/
4147 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4149 formal_arg
= gfc_get_formal_arglist ();
4150 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4152 /* May need to copy more info for the symbol. */
4153 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4154 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4155 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4156 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4158 /* If this isn't the first arg, set up the next ptr. For the
4159 last arg built, the formal_arg->next will never get set to
4160 anything other than NULL. */
4161 if (formal_prev
!= NULL
)
4162 formal_prev
->next
= formal_arg
;
4164 formal_arg
->next
= NULL
;
4166 formal_prev
= formal_arg
;
4168 /* Add arg to list of formal args. */
4169 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4171 /* Validate changes. */
4172 gfc_commit_symbol (formal_arg
->sym
);
4175 /* Add the interface to the symbol. */
4176 gfc_free_formal_arglist (dest
->formal
);
4177 dest
->formal
= head
;
4178 dest
->attr
.if_source
= IFSRC_DECL
;
4180 /* Store the formal namespace information. */
4181 if (dest
->formal
!= NULL
)
4182 /* The current ns should be that for the dest proc. */
4183 dest
->formal_ns
= gfc_current_ns
;
4184 /* Restore the current namespace to what it was on entry. */
4185 gfc_current_ns
= parent_ns
;
4189 /* Builds the parameter list for the iso_c_binding procedure
4190 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4191 generic version of either the c_f_pointer or c_f_procpointer
4192 functions. The new_proc_sym represents a "resolved" version of the
4193 symbol. The functions are resolved to match the types of their
4194 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4195 something similar to c_f_pointer_i4 if the type of data object fptr
4196 pointed to was a default integer. The actual name of the resolved
4197 procedure symbol is further mangled with the module name, etc., but
4198 the idea holds true. */
4201 build_formal_args (gfc_symbol
*new_proc_sym
,
4202 gfc_symbol
*old_sym
, int add_optional_arg
)
4204 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
4205 gfc_namespace
*parent_ns
= NULL
;
4207 parent_ns
= gfc_current_ns
;
4208 /* Create a new namespace, which will be the formal ns (namespace
4209 of the formal args). */
4210 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
4211 gfc_current_ns
->proc_name
= new_proc_sym
;
4213 /* Generate the params. */
4214 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
4216 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4217 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4218 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4219 gfc_current_ns
, "fptr", 1);
4221 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
4223 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4224 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4225 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4226 gfc_current_ns
, "fptr", 0);
4227 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4228 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
4229 gfc_current_ns
, "shape");
4232 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
4234 /* c_associated has one required arg and one optional; both
4236 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4237 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
4238 if (add_optional_arg
)
4240 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4241 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
4242 /* The last param is optional so mark it as such. */
4243 tail
->sym
->attr
.optional
= 1;
4247 /* Add the interface (store formal args to new_proc_sym). */
4248 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
4250 /* Set up the formal_ns pointer to the one created for the
4251 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4252 new_proc_sym
->formal_ns
= gfc_current_ns
;
4254 gfc_current_ns
= parent_ns
;
4258 std_for_isocbinding_symbol (int id
)
4262 #define NAMED_INTCST(a,b,c,d) \
4265 #include "iso-c-binding.def"
4268 #define NAMED_FUNCTION(a,b,c,d) \
4271 #include "iso-c-binding.def"
4272 #undef NAMED_FUNCTION
4275 return GFC_STD_F2003
;
4279 /* Generate the given set of C interoperable kind objects, or all
4280 interoperable kinds. This function will only be given kind objects
4281 for valid iso_c_binding defined types because this is verified when
4282 the 'use' statement is parsed. If the user gives an 'only' clause,
4283 the specific kinds are looked up; if they don't exist, an error is
4284 reported. If the user does not give an 'only' clause, all
4285 iso_c_binding symbols are generated. If a list of specific kinds
4286 is given, it must have a NULL in the first empty spot to mark the
4291 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4292 const char *local_name
)
4294 const char *const name
= (local_name
&& local_name
[0]) ? local_name
4295 : c_interop_kinds_table
[s
].name
;
4296 gfc_symtree
*tmp_symtree
= NULL
;
4297 gfc_symbol
*tmp_sym
= NULL
;
4298 gfc_dt_list
**dt_list_ptr
= NULL
;
4299 gfc_component
*tmp_comp
= NULL
;
4300 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
4303 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4305 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4307 /* Already exists in this scope so don't re-add it.
4308 TODO: we should probably check that it's really the same symbol. */
4309 if (tmp_symtree
!= NULL
)
4312 /* Create the sym tree in the current ns. */
4313 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4315 tmp_sym
= tmp_symtree
->n
.sym
;
4317 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4320 /* Say what module this symbol belongs to. */
4321 tmp_sym
->module
= gfc_get_string (mod_name
);
4322 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4323 tmp_sym
->intmod_sym_id
= s
;
4328 #define NAMED_INTCST(a,b,c,d) case a :
4329 #define NAMED_REALCST(a,b,c) case a :
4330 #define NAMED_CMPXCST(a,b,c) case a :
4331 #define NAMED_LOGCST(a,b,c) case a :
4332 #define NAMED_CHARKNDCST(a,b,c) case a :
4333 #include "iso-c-binding.def"
4335 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4336 c_interop_kinds_table
[s
].value
);
4338 /* Initialize an integer constant expression node. */
4339 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4340 tmp_sym
->ts
.type
= BT_INTEGER
;
4341 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4343 /* Mark this type as a C interoperable one. */
4344 tmp_sym
->ts
.is_c_interop
= 1;
4345 tmp_sym
->ts
.is_iso_c
= 1;
4346 tmp_sym
->value
->ts
.is_c_interop
= 1;
4347 tmp_sym
->value
->ts
.is_iso_c
= 1;
4348 tmp_sym
->attr
.is_c_interop
= 1;
4350 /* Tell what f90 type this c interop kind is valid. */
4351 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4353 /* Say it's from the iso_c_binding module. */
4354 tmp_sym
->attr
.is_iso_c
= 1;
4356 /* Make it use associated. */
4357 tmp_sym
->attr
.use_assoc
= 1;
4361 #define NAMED_CHARCST(a,b,c) case a :
4362 #include "iso-c-binding.def"
4364 /* Initialize an integer constant expression node for the
4365 length of the character. */
4366 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4367 &gfc_current_locus
, NULL
, 1);
4368 tmp_sym
->value
->ts
.is_c_interop
= 1;
4369 tmp_sym
->value
->ts
.is_iso_c
= 1;
4370 tmp_sym
->value
->value
.character
.length
= 1;
4371 tmp_sym
->value
->value
.character
.string
[0]
4372 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4373 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4374 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4377 /* May not need this in both attr and ts, but do need in
4378 attr for writing module file. */
4379 tmp_sym
->attr
.is_c_interop
= 1;
4381 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4382 tmp_sym
->ts
.type
= BT_CHARACTER
;
4384 /* Need to set it to the C_CHAR kind. */
4385 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4387 /* Mark this type as a C interoperable one. */
4388 tmp_sym
->ts
.is_c_interop
= 1;
4389 tmp_sym
->ts
.is_iso_c
= 1;
4391 /* Tell what f90 type this c interop kind is valid. */
4392 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4394 /* Say it's from the iso_c_binding module. */
4395 tmp_sym
->attr
.is_iso_c
= 1;
4397 /* Make it use associated. */
4398 tmp_sym
->attr
.use_assoc
= 1;
4401 case ISOCBINDING_PTR
:
4402 case ISOCBINDING_FUNPTR
:
4404 /* Initialize an integer constant expression node. */
4405 tmp_sym
->attr
.flavor
= FL_DERIVED
;
4406 tmp_sym
->ts
.is_c_interop
= 1;
4407 tmp_sym
->attr
.is_c_interop
= 1;
4408 tmp_sym
->attr
.is_iso_c
= 1;
4409 tmp_sym
->ts
.is_iso_c
= 1;
4410 tmp_sym
->ts
.type
= BT_DERIVED
;
4412 /* A derived type must have the bind attribute to be
4413 interoperable (J3/04-007, Section 15.2.3), even though
4414 the binding label is not used. */
4415 tmp_sym
->attr
.is_bind_c
= 1;
4417 tmp_sym
->attr
.referenced
= 1;
4419 tmp_sym
->ts
.u
.derived
= tmp_sym
;
4421 /* Add the symbol created for the derived type to the current ns. */
4422 dt_list_ptr
= &(gfc_derived_types
);
4423 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4424 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4426 /* There is already at least one derived type in the list, so append
4427 the one we're currently building for c_ptr or c_funptr. */
4428 if (*dt_list_ptr
!= NULL
)
4429 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4430 (*dt_list_ptr
) = gfc_get_dt_list ();
4431 (*dt_list_ptr
)->derived
= tmp_sym
;
4432 (*dt_list_ptr
)->next
= NULL
;
4434 /* Set up the component of the derived type, which will be
4435 an integer with kind equal to c_ptr_size. Mangle the name of
4436 the field for the c_address to prevent the curious user from
4437 trying to access it from Fortran. */
4438 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
4439 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
4440 if (tmp_comp
== NULL
)
4441 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4442 "create component for c_address");
4444 tmp_comp
->ts
.type
= BT_INTEGER
;
4446 /* Set this because the module will need to read/write this field. */
4447 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4449 /* The kinds for c_ptr and c_funptr are the same. */
4450 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4451 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4453 tmp_comp
->attr
.pointer
= 0;
4454 tmp_comp
->attr
.dimension
= 0;
4456 /* Mark the component as C interoperable. */
4457 tmp_comp
->ts
.is_c_interop
= 1;
4459 /* Make it use associated (iso_c_binding module). */
4460 tmp_sym
->attr
.use_assoc
= 1;
4463 case ISOCBINDING_NULL_PTR
:
4464 case ISOCBINDING_NULL_FUNPTR
:
4465 gen_special_c_interop_ptr (s
, name
, mod_name
);
4468 case ISOCBINDING_F_POINTER
:
4469 case ISOCBINDING_ASSOCIATED
:
4470 case ISOCBINDING_LOC
:
4471 case ISOCBINDING_FUNLOC
:
4472 case ISOCBINDING_F_PROCPOINTER
:
4474 tmp_sym
->attr
.proc
= PROC_MODULE
;
4476 /* Use the procedure's name as it is in the iso_c_binding module for
4477 setting the binding label in case the user renamed the symbol. */
4478 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
4479 c_interop_kinds_table
[s
].name
);
4480 tmp_sym
->attr
.is_iso_c
= 1;
4481 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4482 tmp_sym
->attr
.subroutine
= 1;
4485 /* TODO! This needs to be finished more for the expr of the
4486 function or something!
4487 This may not need to be here, because trying to do c_loc
4489 if (s
== ISOCBINDING_ASSOCIATED
)
4491 tmp_sym
->attr
.function
= 1;
4492 tmp_sym
->ts
.type
= BT_LOGICAL
;
4493 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4494 tmp_sym
->result
= tmp_sym
;
4498 /* Here, we're taking the simple approach. We're defining
4499 c_loc as an external identifier so the compiler will put
4500 what we expect on the stack for the address we want the
4502 tmp_sym
->ts
.type
= BT_DERIVED
;
4503 if (s
== ISOCBINDING_LOC
)
4504 tmp_sym
->ts
.u
.derived
=
4505 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4507 tmp_sym
->ts
.u
.derived
=
4508 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4510 if (tmp_sym
->ts
.u
.derived
== NULL
)
4512 /* Create the necessary derived type so we can continue
4513 processing the file. */
4514 generate_isocbinding_symbol
4515 (mod_name
, s
== ISOCBINDING_FUNLOC
4516 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4517 (const char *)(s
== ISOCBINDING_FUNLOC
4518 ? "_gfortran_iso_c_binding_c_funptr"
4519 : "_gfortran_iso_c_binding_c_ptr"));
4520 tmp_sym
->ts
.u
.derived
=
4521 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4522 ? ISOCBINDING_FUNPTR
4526 /* The function result is itself (no result clause). */
4527 tmp_sym
->result
= tmp_sym
;
4528 tmp_sym
->attr
.external
= 1;
4529 tmp_sym
->attr
.use_assoc
= 0;
4530 tmp_sym
->attr
.pure
= 1;
4531 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4532 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4536 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4537 tmp_sym
->attr
.contained
= 0;
4539 /* Try using this builder routine, with the new and old symbols
4540 both being the generic iso_c proc sym being created. This
4541 will create the formal args (and the new namespace for them).
4542 Don't build an arg list for c_loc because we're going to treat
4543 c_loc as an external procedure. */
4544 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4545 /* The 1 says to add any optional args, if applicable. */
4546 build_formal_args (tmp_sym
, tmp_sym
, 1);
4548 /* Set this after setting up the symbol, to prevent error messages. */
4549 tmp_sym
->attr
.use_assoc
= 1;
4551 /* This symbol will not be referenced directly. It will be
4552 resolved to the implementation for the given f90 kind. */
4553 tmp_sym
->attr
.referenced
= 0;
4560 gfc_commit_symbol (tmp_sym
);
4564 /* Creates a new symbol based off of an old iso_c symbol, with a new
4565 binding label. This function can be used to create a new,
4566 resolved, version of a procedure symbol for c_f_pointer or
4567 c_f_procpointer that is based on the generic symbols. A new
4568 parameter list is created for the new symbol using
4569 build_formal_args(). The add_optional_flag specifies whether the
4570 to add the optional SHAPE argument. The new symbol is
4574 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4575 char *new_binding_label
, int add_optional_arg
)
4577 gfc_symtree
*new_symtree
= NULL
;
4579 /* See if we have a symbol by that name already available, looking
4580 through any parent namespaces. */
4581 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4582 if (new_symtree
!= NULL
)
4583 /* Return the existing symbol. */
4584 return new_symtree
->n
.sym
;
4586 /* Create the symtree/symbol, with attempted host association. */
4587 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4588 if (new_symtree
== NULL
)
4589 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4590 "symtree for '%s'", new_name
);
4592 /* Now fill in the fields of the resolved symbol with the old sym. */
4593 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4594 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4595 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4596 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4597 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4598 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4599 if (old_sym
->attr
.function
)
4600 new_symtree
->n
.sym
->result
= new_symtree
->n
.sym
;
4601 /* Build the formal arg list. */
4602 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4604 gfc_commit_symbol (new_symtree
->n
.sym
);
4606 return new_symtree
->n
.sym
;
4610 /* Check that a symbol is already typed. If strict is not set, an untyped
4611 symbol is acceptable for non-standard-conforming mode. */
4614 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4615 bool strict
, locus where
)
4619 if (gfc_matching_prefix
)
4622 /* Check for the type and try to give it an implicit one. */
4623 if (sym
->ts
.type
== BT_UNKNOWN
4624 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4628 gfc_error ("Symbol '%s' is used before it is typed at %L",
4633 if (gfc_notify_std (GFC_STD_GNU
,
4634 "Extension: Symbol '%s' is used before"
4635 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4639 /* Everything is ok. */
4644 /* Construct a typebound-procedure structure. Those are stored in a tentative
4645 list and marked `error' until symbols are committed. */
4648 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4650 gfc_typebound_proc
*result
;
4651 tentative_tbp
*list_node
;
4653 result
= XCNEW (gfc_typebound_proc
);
4658 list_node
= XCNEW (tentative_tbp
);
4659 list_node
->next
= tentative_tbp_list
;
4660 list_node
->proc
= result
;
4661 tentative_tbp_list
= list_node
;
4667 /* Get the super-type of a given derived type. */
4670 gfc_get_derived_super_type (gfc_symbol
* derived
)
4672 if (!derived
->attr
.extension
)
4675 gcc_assert (derived
->components
);
4676 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4677 gcc_assert (derived
->components
->ts
.u
.derived
);
4679 return derived
->components
->ts
.u
.derived
;
4683 /* Get the ultimate super-type of a given derived type. */
4686 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4688 if (!derived
->attr
.extension
)
4691 derived
= gfc_get_derived_super_type (derived
);
4693 if (derived
->attr
.extension
)
4694 return gfc_get_ultimate_derived_super_type (derived
);
4700 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4703 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4705 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4706 t2
= gfc_get_derived_super_type (t2
);
4707 return gfc_compare_derived_types (t1
, t2
);
4711 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4712 If ts1 is nonpolymorphic, ts2 must be the same type.
4713 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4716 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4718 bool is_class1
= (ts1
->type
== BT_CLASS
);
4719 bool is_class2
= (ts2
->type
== BT_CLASS
);
4720 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4721 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4723 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
)
4724 return (ts1
->type
== ts2
->type
);
4726 if (is_derived1
&& is_derived2
)
4727 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4729 if (is_class1
&& is_derived2
)
4730 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4732 else if (is_class1
&& is_class2
)
4733 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4734 ts2
->u
.derived
->components
->ts
.u
.derived
);
4740 /* Find the parent-namespace of the current function. If we're inside
4741 BLOCK constructs, it may not be the current one. */
4744 gfc_find_proc_namespace (gfc_namespace
* ns
)
4746 while (ns
->construct_entities
)
4756 /* Check if an associate-variable should be translated as an `implicit' pointer
4757 internally (if it is associated to a variable and not an array with
4761 gfc_is_associate_pointer (gfc_symbol
* sym
)
4766 if (!sym
->assoc
->variable
)
4769 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)