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 && gfc_option
.warn_c_binding_type
)
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
291 && gfc_option
.warn_c_binding_type
)
293 /* Dummy args to a BIND(C) routine may not be interoperable if
294 they are implicitly typed. */
295 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
296 "be C interoperable but it is a dummy argument to "
297 "the BIND(C) procedure '%s' at %L", sym
->name
,
298 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
299 &(sym
->ns
->proc_name
->declared_at
));
300 sym
->ts
.f90_type
= sym
->ts
.type
;
308 /* This function is called from parse.c(parse_progunit) to check the
309 type of the function is not implicitly typed in the host namespace
310 and to implicitly type the function result, if necessary. */
313 gfc_check_function_type (gfc_namespace
*ns
)
315 gfc_symbol
*proc
= ns
->proc_name
;
317 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
320 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
322 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
325 if (proc
->result
!= proc
)
327 proc
->ts
= proc
->result
->ts
;
328 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
329 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
330 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
331 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
334 else if (!proc
->result
->attr
.proc_pointer
)
336 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
337 proc
->result
->name
, &proc
->result
->declared_at
);
338 proc
->result
->attr
.untyped
= 1;
344 /******************** Symbol attribute stuff *********************/
346 /* This is a generic conflict-checker. We do this to avoid having a
347 single conflict in two places. */
349 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
350 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
351 #define conf_std(a, b, std) if (attr->a && attr->b)\
360 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
362 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
363 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
364 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
365 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
366 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
367 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
368 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
369 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
370 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
371 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
372 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
373 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
374 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
375 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
376 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
377 *contiguous
= "CONTIGUOUS", *generic
= "GENERIC";
378 static const char *threadprivate
= "THREADPRIVATE";
384 where
= &gfc_current_locus
;
386 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
390 standard
= GFC_STD_F2003
;
394 if (attr
->in_namelist
&& (attr
->allocatable
|| attr
->pointer
))
397 a2
= attr
->allocatable
? allocatable
: pointer
;
398 standard
= GFC_STD_F2003
;
402 /* Check for attributes not allowed in a BLOCK DATA. */
403 if (gfc_current_state () == COMP_BLOCK_DATA
)
407 if (attr
->in_namelist
)
409 if (attr
->allocatable
)
415 if (attr
->access
== ACCESS_PRIVATE
)
417 if (attr
->access
== ACCESS_PUBLIC
)
419 if (attr
->intent
!= INTENT_UNKNOWN
)
425 ("%s attribute not allowed in BLOCK DATA program unit at %L",
431 if (attr
->save
== SAVE_EXPLICIT
)
434 conf (in_common
, save
);
437 switch (attr
->flavor
)
445 a1
= gfc_code2string (flavors
, attr
->flavor
);
449 gfc_error ("Namelist group name at %L cannot have the "
450 "SAVE attribute", where
);
454 /* Conflicts between SAVE and PROCEDURE will be checked at
455 resolution stage, see "resolve_fl_procedure". */
463 conf (dummy
, intrinsic
);
464 conf (dummy
, threadprivate
);
465 conf (pointer
, target
);
466 conf (pointer
, intrinsic
);
467 conf (pointer
, elemental
);
468 conf (allocatable
, elemental
);
470 conf (target
, external
);
471 conf (target
, intrinsic
);
473 if (!attr
->if_source
)
474 conf (external
, dimension
); /* See Fortran 95's R504. */
476 conf (external
, intrinsic
);
477 conf (entry
, intrinsic
);
479 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
480 conf (external
, subroutine
);
482 if (attr
->proc_pointer
&& gfc_notify_std (GFC_STD_F2003
,
483 "Fortran 2003: Procedure pointer at %C") == FAILURE
)
486 conf (allocatable
, pointer
);
487 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
488 conf_std (allocatable
, function
, GFC_STD_F2003
);
489 conf_std (allocatable
, result
, GFC_STD_F2003
);
490 conf (elemental
, recursive
);
492 conf (in_common
, dummy
);
493 conf (in_common
, allocatable
);
494 conf (in_common
, codimension
);
495 conf (in_common
, result
);
497 conf (in_equivalence
, use_assoc
);
498 conf (in_equivalence
, codimension
);
499 conf (in_equivalence
, dummy
);
500 conf (in_equivalence
, target
);
501 conf (in_equivalence
, pointer
);
502 conf (in_equivalence
, function
);
503 conf (in_equivalence
, result
);
504 conf (in_equivalence
, entry
);
505 conf (in_equivalence
, allocatable
);
506 conf (in_equivalence
, threadprivate
);
508 conf (dummy
, result
);
509 conf (entry
, result
);
510 conf (generic
, result
);
512 conf (function
, subroutine
);
514 if (!function
&& !subroutine
)
515 conf (is_bind_c
, dummy
);
517 conf (is_bind_c
, cray_pointer
);
518 conf (is_bind_c
, cray_pointee
);
519 conf (is_bind_c
, codimension
);
520 conf (is_bind_c
, allocatable
);
521 conf (is_bind_c
, elemental
);
523 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
524 Parameter conflict caught below. Also, value cannot be specified
525 for a dummy procedure. */
527 /* Cray pointer/pointee conflicts. */
528 conf (cray_pointer
, cray_pointee
);
529 conf (cray_pointer
, dimension
);
530 conf (cray_pointer
, codimension
);
531 conf (cray_pointer
, contiguous
);
532 conf (cray_pointer
, pointer
);
533 conf (cray_pointer
, target
);
534 conf (cray_pointer
, allocatable
);
535 conf (cray_pointer
, external
);
536 conf (cray_pointer
, intrinsic
);
537 conf (cray_pointer
, in_namelist
);
538 conf (cray_pointer
, function
);
539 conf (cray_pointer
, subroutine
);
540 conf (cray_pointer
, entry
);
542 conf (cray_pointee
, allocatable
);
543 conf (cray_pointer
, contiguous
);
544 conf (cray_pointer
, codimension
);
545 conf (cray_pointee
, intent
);
546 conf (cray_pointee
, optional
);
547 conf (cray_pointee
, dummy
);
548 conf (cray_pointee
, target
);
549 conf (cray_pointee
, intrinsic
);
550 conf (cray_pointee
, pointer
);
551 conf (cray_pointee
, entry
);
552 conf (cray_pointee
, in_common
);
553 conf (cray_pointee
, in_equivalence
);
554 conf (cray_pointee
, threadprivate
);
557 conf (data
, function
);
559 conf (data
, allocatable
);
561 conf (value
, pointer
)
562 conf (value
, allocatable
)
563 conf (value
, subroutine
)
564 conf (value
, function
)
565 conf (value
, volatile_
)
566 conf (value
, dimension
)
567 conf (value
, codimension
)
568 conf (value
, external
)
570 conf (codimension
, result
)
573 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
576 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
580 conf (is_protected
, intrinsic
)
581 conf (is_protected
, in_common
)
583 conf (asynchronous
, intrinsic
)
584 conf (asynchronous
, external
)
586 conf (volatile_
, intrinsic
)
587 conf (volatile_
, external
)
589 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
596 conf (procedure
, allocatable
)
597 conf (procedure
, dimension
)
598 conf (procedure
, codimension
)
599 conf (procedure
, intrinsic
)
600 conf (procedure
, target
)
601 conf (procedure
, value
)
602 conf (procedure
, volatile_
)
603 conf (procedure
, asynchronous
)
604 conf (procedure
, entry
)
606 a1
= gfc_code2string (flavors
, attr
->flavor
);
608 if (attr
->in_namelist
609 && attr
->flavor
!= FL_VARIABLE
610 && attr
->flavor
!= FL_PROCEDURE
611 && attr
->flavor
!= FL_UNKNOWN
)
617 switch (attr
->flavor
)
627 conf2 (asynchronous
);
630 conf2 (is_protected
);
640 conf2 (threadprivate
);
642 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
644 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
645 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
652 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
666 /* Conflicts with INTENT, SAVE and RESULT will be checked
667 at resolution stage, see "resolve_fl_procedure". */
669 if (attr
->subroutine
)
675 conf2 (asynchronous
);
680 if (!attr
->proc_pointer
)
681 conf2 (threadprivate
);
684 if (!attr
->proc_pointer
)
689 case PROC_ST_FUNCTION
:
700 conf2 (threadprivate
);
720 conf2 (threadprivate
);
723 if (attr
->intent
!= INTENT_UNKNOWN
)
740 conf2 (is_protected
);
746 conf2 (asynchronous
);
747 conf2 (threadprivate
);
763 gfc_error ("%s attribute conflicts with %s attribute at %L",
766 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
767 a1
, a2
, name
, where
);
774 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
775 "with %s attribute at %L", a1
, a2
,
780 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
781 "with %s attribute in '%s' at %L",
782 a1
, a2
, name
, where
);
791 /* Mark a symbol as referenced. */
794 gfc_set_sym_referenced (gfc_symbol
*sym
)
797 if (sym
->attr
.referenced
)
800 sym
->attr
.referenced
= 1;
802 /* Remember which order dummy variables are accessed in. */
804 sym
->dummy_order
= next_dummy_order
++;
808 /* Common subroutine called by attribute changing subroutines in order
809 to prevent them from changing a symbol that has been
810 use-associated. Returns zero if it is OK to change the symbol,
814 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
817 if (attr
->use_assoc
== 0)
821 where
= &gfc_current_locus
;
824 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
827 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
834 /* Generate an error because of a duplicate attribute. */
837 duplicate_attr (const char *attr
, locus
*where
)
841 where
= &gfc_current_locus
;
843 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
848 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
849 locus
*where ATTRIBUTE_UNUSED
)
851 attr
->ext_attr
|= 1 << ext_attr
;
856 /* Called from decl.c (attr_decl1) to check attributes, when declared
860 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
862 if (check_used (attr
, NULL
, where
))
865 return check_conflict (attr
, NULL
, where
);
870 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
873 if (check_used (attr
, NULL
, where
))
876 if (attr
->allocatable
)
878 duplicate_attr ("ALLOCATABLE", where
);
882 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
883 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
885 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
890 attr
->allocatable
= 1;
891 return check_conflict (attr
, NULL
, where
);
896 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
899 if (check_used (attr
, name
, where
))
902 if (attr
->codimension
)
904 duplicate_attr ("CODIMENSION", where
);
908 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
909 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
911 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
912 "at %L", name
, where
);
916 attr
->codimension
= 1;
917 return check_conflict (attr
, name
, where
);
922 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
925 if (check_used (attr
, name
, where
))
930 duplicate_attr ("DIMENSION", where
);
934 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
935 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
937 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
938 "at %L", name
, where
);
943 return check_conflict (attr
, name
, where
);
948 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
951 if (check_used (attr
, name
, where
))
954 attr
->contiguous
= 1;
955 return check_conflict (attr
, name
, where
);
960 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
963 if (check_used (attr
, NULL
, where
))
968 duplicate_attr ("EXTERNAL", where
);
972 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
975 attr
->proc_pointer
= 1;
980 return check_conflict (attr
, NULL
, where
);
985 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
988 if (check_used (attr
, NULL
, where
))
993 duplicate_attr ("INTRINSIC", where
);
999 return check_conflict (attr
, NULL
, where
);
1004 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
1007 if (check_used (attr
, NULL
, where
))
1012 duplicate_attr ("OPTIONAL", where
);
1017 return check_conflict (attr
, NULL
, where
);
1022 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1025 if (check_used (attr
, NULL
, where
))
1028 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1029 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1031 duplicate_attr ("POINTER", where
);
1035 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1036 || (attr
->if_source
== IFSRC_IFBODY
1037 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1038 attr
->proc_pointer
= 1;
1042 return check_conflict (attr
, NULL
, where
);
1047 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1050 if (check_used (attr
, NULL
, where
))
1053 attr
->cray_pointer
= 1;
1054 return check_conflict (attr
, NULL
, where
);
1059 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1062 if (check_used (attr
, NULL
, where
))
1065 if (attr
->cray_pointee
)
1067 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1068 " statements", where
);
1072 attr
->cray_pointee
= 1;
1073 return check_conflict (attr
, NULL
, where
);
1078 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1080 if (check_used (attr
, name
, where
))
1083 if (attr
->is_protected
)
1085 if (gfc_notify_std (GFC_STD_LEGACY
,
1086 "Duplicate PROTECTED attribute specified at %L",
1092 attr
->is_protected
= 1;
1093 return check_conflict (attr
, name
, where
);
1098 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1101 if (check_used (attr
, name
, where
))
1105 return check_conflict (attr
, name
, where
);
1110 gfc_add_save (symbol_attribute
*attr
, save_state s
, const char *name
,
1114 if (check_used (attr
, name
, where
))
1117 if (s
== SAVE_EXPLICIT
&& gfc_pure (NULL
))
1120 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1125 if (s
== SAVE_EXPLICIT
&& gfc_implicit_pure (NULL
))
1126 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1128 if (s
== SAVE_EXPLICIT
&& attr
->save
== SAVE_EXPLICIT
)
1130 if (gfc_notify_std (GFC_STD_LEGACY
,
1131 "Duplicate SAVE attribute specified at %L",
1138 return check_conflict (attr
, name
, where
);
1143 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1146 if (check_used (attr
, name
, where
))
1151 if (gfc_notify_std (GFC_STD_LEGACY
,
1152 "Duplicate VALUE attribute specified at %L",
1159 return check_conflict (attr
, name
, where
);
1164 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1166 /* No check_used needed as 11.2.1 of the F2003 standard allows
1167 that the local identifier made accessible by a use statement can be
1168 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1170 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1171 if (gfc_notify_std (GFC_STD_LEGACY
,
1172 "Duplicate VOLATILE attribute specified at %L", where
)
1176 attr
->volatile_
= 1;
1177 attr
->volatile_ns
= gfc_current_ns
;
1178 return check_conflict (attr
, name
, where
);
1183 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1185 /* No check_used needed as 11.2.1 of the F2003 standard allows
1186 that the local identifier made accessible by a use statement can be
1187 given a ASYNCHRONOUS attribute. */
1189 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1190 if (gfc_notify_std (GFC_STD_LEGACY
,
1191 "Duplicate ASYNCHRONOUS attribute specified at %L",
1195 attr
->asynchronous
= 1;
1196 attr
->asynchronous_ns
= gfc_current_ns
;
1197 return check_conflict (attr
, name
, where
);
1202 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1205 if (check_used (attr
, name
, where
))
1208 if (attr
->threadprivate
)
1210 duplicate_attr ("THREADPRIVATE", where
);
1214 attr
->threadprivate
= 1;
1215 return check_conflict (attr
, name
, where
);
1220 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1223 if (check_used (attr
, NULL
, where
))
1228 duplicate_attr ("TARGET", where
);
1233 return check_conflict (attr
, NULL
, where
);
1238 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1241 if (check_used (attr
, name
, where
))
1244 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1246 return check_conflict (attr
, name
, where
);
1251 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1254 if (check_used (attr
, name
, where
))
1257 /* Duplicate attribute already checked for. */
1258 attr
->in_common
= 1;
1259 return check_conflict (attr
, name
, where
);
1264 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1267 /* Duplicate attribute already checked for. */
1268 attr
->in_equivalence
= 1;
1269 if (check_conflict (attr
, name
, where
) == FAILURE
)
1272 if (attr
->flavor
== FL_VARIABLE
)
1275 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1280 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1283 if (check_used (attr
, name
, where
))
1287 return check_conflict (attr
, name
, where
);
1292 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1295 attr
->in_namelist
= 1;
1296 return check_conflict (attr
, name
, where
);
1301 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1304 if (check_used (attr
, name
, where
))
1308 return check_conflict (attr
, name
, where
);
1313 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1316 if (check_used (attr
, NULL
, where
))
1319 if (attr
->elemental
)
1321 duplicate_attr ("ELEMENTAL", where
);
1325 attr
->elemental
= 1;
1326 return check_conflict (attr
, NULL
, where
);
1331 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1334 if (check_used (attr
, NULL
, where
))
1339 duplicate_attr ("PURE", where
);
1344 return check_conflict (attr
, NULL
, where
);
1349 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1352 if (check_used (attr
, NULL
, where
))
1355 if (attr
->recursive
)
1357 duplicate_attr ("RECURSIVE", where
);
1361 attr
->recursive
= 1;
1362 return check_conflict (attr
, NULL
, where
);
1367 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1370 if (check_used (attr
, name
, where
))
1375 duplicate_attr ("ENTRY", where
);
1380 return check_conflict (attr
, name
, where
);
1385 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1388 if (attr
->flavor
!= FL_PROCEDURE
1389 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1393 return check_conflict (attr
, name
, where
);
1398 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1401 if (attr
->flavor
!= FL_PROCEDURE
1402 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1405 attr
->subroutine
= 1;
1406 return check_conflict (attr
, name
, where
);
1411 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1414 if (attr
->flavor
!= FL_PROCEDURE
1415 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1419 return check_conflict (attr
, name
, where
);
1424 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1427 if (check_used (attr
, NULL
, where
))
1430 if (attr
->flavor
!= FL_PROCEDURE
1431 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1434 if (attr
->procedure
)
1436 duplicate_attr ("PROCEDURE", where
);
1440 attr
->procedure
= 1;
1442 return check_conflict (attr
, NULL
, where
);
1447 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1451 duplicate_attr ("ABSTRACT", where
);
1460 /* Flavors are special because some flavors are not what Fortran
1461 considers attributes and can be reaffirmed multiple times. */
1464 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1468 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1469 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1470 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1473 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1476 if (attr
->flavor
!= FL_UNKNOWN
)
1479 where
= &gfc_current_locus
;
1482 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1483 gfc_code2string (flavors
, attr
->flavor
), name
,
1484 gfc_code2string (flavors
, f
), where
);
1486 gfc_error ("%s attribute conflicts with %s attribute at %L",
1487 gfc_code2string (flavors
, attr
->flavor
),
1488 gfc_code2string (flavors
, f
), where
);
1495 return check_conflict (attr
, name
, where
);
1500 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1501 const char *name
, locus
*where
)
1504 if (check_used (attr
, name
, where
))
1507 if (attr
->flavor
!= FL_PROCEDURE
1508 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1512 where
= &gfc_current_locus
;
1514 if (attr
->proc
!= PROC_UNKNOWN
)
1516 gfc_error ("%s procedure at %L is already declared as %s procedure",
1517 gfc_code2string (procedures
, t
), where
,
1518 gfc_code2string (procedures
, attr
->proc
));
1525 /* Statement functions are always scalar and functions. */
1526 if (t
== PROC_ST_FUNCTION
1527 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1528 || attr
->dimension
))
1531 return check_conflict (attr
, name
, where
);
1536 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1539 if (check_used (attr
, NULL
, where
))
1542 if (attr
->intent
== INTENT_UNKNOWN
)
1544 attr
->intent
= intent
;
1545 return check_conflict (attr
, NULL
, where
);
1549 where
= &gfc_current_locus
;
1551 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1552 gfc_intent_string (attr
->intent
),
1553 gfc_intent_string (intent
), where
);
1559 /* No checks for use-association in public and private statements. */
1562 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1563 const char *name
, locus
*where
)
1566 if (attr
->access
== ACCESS_UNKNOWN
1567 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1569 attr
->access
= access
;
1570 return check_conflict (attr
, name
, where
);
1574 where
= &gfc_current_locus
;
1575 gfc_error ("ACCESS specification at %L was already specified", where
);
1581 /* Set the is_bind_c field for the given symbol_attribute. */
1584 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1585 int is_proc_lang_bind_spec
)
1588 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1589 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1590 "variables or common blocks", where
);
1591 else if (attr
->is_bind_c
)
1592 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1594 attr
->is_bind_c
= 1;
1597 where
= &gfc_current_locus
;
1599 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1603 return check_conflict (attr
, name
, where
);
1607 /* Set the extension field for the given symbol_attribute. */
1610 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1613 where
= &gfc_current_locus
;
1615 if (attr
->extension
)
1616 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1618 attr
->extension
= 1;
1620 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1629 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1630 gfc_formal_arglist
* formal
, locus
*where
)
1633 if (check_used (&sym
->attr
, sym
->name
, where
))
1637 where
= &gfc_current_locus
;
1639 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1640 && sym
->attr
.if_source
!= IFSRC_DECL
)
1642 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1647 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1649 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1650 "body", sym
->name
, where
);
1654 sym
->formal
= formal
;
1655 sym
->attr
.if_source
= source
;
1661 /* Add a type to a symbol. */
1664 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1670 where
= &gfc_current_locus
;
1673 type
= sym
->result
->ts
.type
;
1675 type
= sym
->ts
.type
;
1677 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1678 type
= sym
->ns
->proc_name
->ts
.type
;
1680 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1682 if (sym
->attr
.use_assoc
)
1683 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1684 "use-associated at %L", sym
->name
, where
, sym
->module
,
1687 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1688 where
, gfc_basic_typename (type
));
1692 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1694 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1695 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1699 flavor
= sym
->attr
.flavor
;
1701 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1702 || flavor
== FL_LABEL
1703 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1704 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1706 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1715 /* Clears all attributes. */
1718 gfc_clear_attr (symbol_attribute
*attr
)
1720 memset (attr
, 0, sizeof (symbol_attribute
));
1724 /* Check for missing attributes in the new symbol. Currently does
1725 nothing, but it's not clear that it is unnecessary yet. */
1728 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1729 locus
*where ATTRIBUTE_UNUSED
)
1736 /* Copy an attribute to a symbol attribute, bit by bit. Some
1737 attributes have a lot of side-effects but cannot be present given
1738 where we are called from, so we ignore some bits. */
1741 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1743 int is_proc_lang_bind_spec
;
1745 /* In line with the other attributes, we only add bits but do not remove
1746 them; cf. also PR 41034. */
1747 dest
->ext_attr
|= src
->ext_attr
;
1749 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1752 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1754 if (src
->codimension
&& gfc_add_codimension (dest
, NULL
, where
) == FAILURE
)
1756 if (src
->contiguous
&& gfc_add_contiguous (dest
, NULL
, where
) == FAILURE
)
1758 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1760 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1762 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1764 if (src
->save
&& gfc_add_save (dest
, src
->save
, NULL
, where
) == FAILURE
)
1766 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1768 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1770 if (src
->asynchronous
&& gfc_add_asynchronous (dest
, NULL
, where
) == FAILURE
)
1772 if (src
->threadprivate
1773 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1775 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1777 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1779 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1784 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1787 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1790 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1792 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1794 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1797 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1799 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1801 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1803 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1806 if (src
->flavor
!= FL_UNKNOWN
1807 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1810 if (src
->intent
!= INTENT_UNKNOWN
1811 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1814 if (src
->access
!= ACCESS_UNKNOWN
1815 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1818 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1821 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1823 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1826 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1828 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1832 if (src
->is_c_interop
)
1833 dest
->is_c_interop
= 1;
1837 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1839 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1841 if (src
->proc_pointer
)
1842 dest
->proc_pointer
= 1;
1851 /************** Component name management ************/
1853 /* Component names of a derived type form their own little namespaces
1854 that are separate from all other spaces. The space is composed of
1855 a singly linked list of gfc_component structures whose head is
1856 located in the parent symbol. */
1859 /* Add a component name to a symbol. The call fails if the name is
1860 already present. On success, the component pointer is modified to
1861 point to the additional component structure. */
1864 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1865 gfc_component
**component
)
1867 gfc_component
*p
, *tail
;
1871 for (p
= sym
->components
; p
; p
= p
->next
)
1873 if (strcmp (p
->name
, name
) == 0)
1875 gfc_error ("Component '%s' at %C already declared at %L",
1883 if (sym
->attr
.extension
1884 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1886 gfc_error ("Component '%s' at %C already in the parent type "
1887 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1891 /* Allocate a new component. */
1892 p
= gfc_get_component ();
1895 sym
->components
= p
;
1899 p
->name
= gfc_get_string (name
);
1900 p
->loc
= gfc_current_locus
;
1901 p
->ts
.type
= BT_UNKNOWN
;
1908 /* Recursive function to switch derived types of all symbol in a
1912 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1920 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1921 sym
->ts
.u
.derived
= to
;
1923 switch_types (st
->left
, from
, to
);
1924 switch_types (st
->right
, from
, to
);
1928 /* This subroutine is called when a derived type is used in order to
1929 make the final determination about which version to use. The
1930 standard requires that a type be defined before it is 'used', but
1931 such types can appear in IMPLICIT statements before the actual
1932 definition. 'Using' in this context means declaring a variable to
1933 be that type or using the type constructor.
1935 If a type is used and the components haven't been defined, then we
1936 have to have a derived type in a parent unit. We find the node in
1937 the other namespace and point the symtree node in this namespace to
1938 that node. Further reference to this name point to the correct
1939 node. If we can't find the node in a parent namespace, then we have
1942 This subroutine takes a pointer to a symbol node and returns a
1943 pointer to the translated node or NULL for an error. Usually there
1944 is no translation and we return the node we were passed. */
1947 gfc_use_derived (gfc_symbol
*sym
)
1957 if (sym
->attr
.generic
)
1958 sym
= gfc_find_dt_in_generic (sym
);
1960 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1961 return sym
; /* Already defined. */
1963 if (sym
->ns
->parent
== NULL
)
1966 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1968 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1972 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1975 /* Get rid of symbol sym, translating all references to s. */
1976 for (i
= 0; i
< GFC_LETTERS
; i
++)
1978 t
= &sym
->ns
->default_type
[i
];
1979 if (t
->u
.derived
== sym
)
1983 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1988 /* Unlink from list of modified symbols. */
1989 gfc_commit_symbol (sym
);
1991 switch_types (sym
->ns
->sym_root
, sym
, s
);
1993 /* TODO: Also have to replace sym -> s in other lists like
1994 namelists, common lists and interface lists. */
1995 gfc_free_symbol (sym
);
2000 gfc_error ("Derived type '%s' at %C is being used before it is defined",
2006 /* Given a derived type node and a component name, try to locate the
2007 component structure. Returns the NULL pointer if the component is
2008 not found or the components are private. If noaccess is set, no access
2012 gfc_find_component (gfc_symbol
*sym
, const char *name
,
2013 bool noaccess
, bool silent
)
2017 if (name
== NULL
|| sym
== NULL
)
2020 sym
= gfc_use_derived (sym
);
2025 for (p
= sym
->components
; p
; p
= p
->next
)
2026 if (strcmp (p
->name
, name
) == 0)
2029 if (p
&& sym
->attr
.use_assoc
&& !noaccess
)
2031 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2032 if (p
->attr
.access
== ACCESS_PRIVATE
||
2033 (p
->attr
.access
!= ACCESS_PUBLIC
2034 && sym
->component_access
== ACCESS_PRIVATE
2035 && !is_parent_comp
))
2038 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2045 && sym
->attr
.extension
2046 && sym
->components
->ts
.type
== BT_DERIVED
)
2048 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2050 /* Do not overwrite the error. */
2055 if (p
== NULL
&& !silent
)
2056 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2063 /* Given a symbol, free all of the component structures and everything
2067 free_components (gfc_component
*p
)
2075 gfc_free_array_spec (p
->as
);
2076 gfc_free_expr (p
->initializer
);
2078 gfc_free_formal_arglist (p
->formal
);
2079 gfc_free_namespace (p
->formal_ns
);
2086 /******************** Statement label management ********************/
2088 /* Comparison function for statement labels, used for managing the
2092 compare_st_labels (void *a1
, void *b1
)
2094 int a
= ((gfc_st_label
*) a1
)->value
;
2095 int b
= ((gfc_st_label
*) b1
)->value
;
2101 /* Free a single gfc_st_label structure, making sure the tree is not
2102 messed up. This function is called only when some parse error
2106 gfc_free_st_label (gfc_st_label
*label
)
2112 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2114 if (label
->format
!= NULL
)
2115 gfc_free_expr (label
->format
);
2121 /* Free a whole tree of gfc_st_label structures. */
2124 free_st_labels (gfc_st_label
*label
)
2130 free_st_labels (label
->left
);
2131 free_st_labels (label
->right
);
2133 if (label
->format
!= NULL
)
2134 gfc_free_expr (label
->format
);
2139 /* Given a label number, search for and return a pointer to the label
2140 structure, creating it if it does not exist. */
2143 gfc_get_st_label (int labelno
)
2148 if (gfc_current_state () == COMP_DERIVED
)
2149 ns
= gfc_current_block ()->f2k_derived
;
2152 /* Find the namespace of the scoping unit:
2153 If we're in a BLOCK construct, jump to the parent namespace. */
2154 ns
= gfc_current_ns
;
2155 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2159 /* First see if the label is already in this namespace. */
2163 if (lp
->value
== labelno
)
2166 if (lp
->value
< labelno
)
2172 lp
= XCNEW (gfc_st_label
);
2174 lp
->value
= labelno
;
2175 lp
->defined
= ST_LABEL_UNKNOWN
;
2176 lp
->referenced
= ST_LABEL_UNKNOWN
;
2178 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2184 /* Called when a statement with a statement label is about to be
2185 accepted. We add the label to the list of the current namespace,
2186 making sure it hasn't been defined previously and referenced
2190 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2194 labelno
= lp
->value
;
2196 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2197 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2198 &lp
->where
, label_locus
);
2201 lp
->where
= *label_locus
;
2205 case ST_LABEL_FORMAT
:
2206 if (lp
->referenced
== ST_LABEL_TARGET
)
2207 gfc_error ("Label %d at %C already referenced as branch target",
2210 lp
->defined
= ST_LABEL_FORMAT
;
2214 case ST_LABEL_TARGET
:
2215 if (lp
->referenced
== ST_LABEL_FORMAT
)
2216 gfc_error ("Label %d at %C already referenced as a format label",
2219 lp
->defined
= ST_LABEL_TARGET
;
2224 lp
->defined
= ST_LABEL_BAD_TARGET
;
2225 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2231 /* Reference a label. Given a label and its type, see if that
2232 reference is consistent with what is known about that label,
2233 updating the unknown state. Returns FAILURE if something goes
2237 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2239 gfc_sl_type label_type
;
2246 labelno
= lp
->value
;
2248 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2249 label_type
= lp
->defined
;
2252 label_type
= lp
->referenced
;
2253 lp
->where
= gfc_current_locus
;
2256 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2258 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2263 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2264 && type
== ST_LABEL_FORMAT
)
2266 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2271 lp
->referenced
= type
;
2279 /************** Symbol table management subroutines ****************/
2281 /* Basic details: Fortran 95 requires a potentially unlimited number
2282 of distinct namespaces when compiling a program unit. This case
2283 occurs during a compilation of internal subprograms because all of
2284 the internal subprograms must be read before we can start
2285 generating code for the host.
2287 Given the tricky nature of the Fortran grammar, we must be able to
2288 undo changes made to a symbol table if the current interpretation
2289 of a statement is found to be incorrect. Whenever a symbol is
2290 looked up, we make a copy of it and link to it. All of these
2291 symbols are kept in a singly linked list so that we can commit or
2292 undo the changes at a later time.
2294 A symtree may point to a symbol node outside of its namespace. In
2295 this case, that symbol has been used as a host associated variable
2296 at some previous time. */
2298 /* Allocate a new namespace structure. Copies the implicit types from
2299 PARENT if PARENT_TYPES is set. */
2302 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2309 ns
= XCNEW (gfc_namespace
);
2310 ns
->sym_root
= NULL
;
2311 ns
->uop_root
= NULL
;
2312 ns
->tb_sym_root
= NULL
;
2313 ns
->finalizers
= NULL
;
2314 ns
->default_access
= ACCESS_UNKNOWN
;
2315 ns
->parent
= parent
;
2317 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2319 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2320 ns
->tb_op
[in
] = NULL
;
2323 /* Initialize default implicit types. */
2324 for (i
= 'a'; i
<= 'z'; i
++)
2326 ns
->set_flag
[i
- 'a'] = 0;
2327 ts
= &ns
->default_type
[i
- 'a'];
2329 if (parent_types
&& ns
->parent
!= NULL
)
2331 /* Copy parent settings. */
2332 *ts
= ns
->parent
->default_type
[i
- 'a'];
2336 if (gfc_option
.flag_implicit_none
!= 0)
2342 if ('i' <= i
&& i
<= 'n')
2344 ts
->type
= BT_INTEGER
;
2345 ts
->kind
= gfc_default_integer_kind
;
2350 ts
->kind
= gfc_default_real_kind
;
2360 /* Comparison function for symtree nodes. */
2363 compare_symtree (void *_st1
, void *_st2
)
2365 gfc_symtree
*st1
, *st2
;
2367 st1
= (gfc_symtree
*) _st1
;
2368 st2
= (gfc_symtree
*) _st2
;
2370 return strcmp (st1
->name
, st2
->name
);
2374 /* Allocate a new symtree node and associate it with the new symbol. */
2377 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2381 st
= XCNEW (gfc_symtree
);
2382 st
->name
= gfc_get_string (name
);
2384 gfc_insert_bbt (root
, st
, compare_symtree
);
2389 /* Delete a symbol from the tree. Does not free the symbol itself! */
2392 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2394 gfc_symtree st
, *st0
;
2396 st0
= gfc_find_symtree (*root
, name
);
2398 st
.name
= gfc_get_string (name
);
2399 gfc_delete_bbt (root
, &st
, compare_symtree
);
2405 /* Given a root symtree node and a name, try to find the symbol within
2406 the namespace. Returns NULL if the symbol is not found. */
2409 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2415 c
= strcmp (name
, st
->name
);
2419 st
= (c
< 0) ? st
->left
: st
->right
;
2426 /* Return a symtree node with a name that is guaranteed to be unique
2427 within the namespace and corresponds to an illegal fortran name. */
2430 gfc_get_unique_symtree (gfc_namespace
*ns
)
2432 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2433 static int serial
= 0;
2435 sprintf (name
, "@%d", serial
++);
2436 return gfc_new_symtree (&ns
->sym_root
, name
);
2440 /* Given a name find a user operator node, creating it if it doesn't
2441 exist. These are much simpler than symbols because they can't be
2442 ambiguous with one another. */
2445 gfc_get_uop (const char *name
)
2450 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2454 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2456 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2457 uop
->name
= gfc_get_string (name
);
2458 uop
->access
= ACCESS_UNKNOWN
;
2459 uop
->ns
= gfc_current_ns
;
2465 /* Given a name find the user operator node. Returns NULL if it does
2469 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2474 ns
= gfc_current_ns
;
2476 st
= gfc_find_symtree (ns
->uop_root
, name
);
2477 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2481 /* Remove a gfc_symbol structure and everything it points to. */
2484 gfc_free_symbol (gfc_symbol
*sym
)
2490 gfc_free_array_spec (sym
->as
);
2492 free_components (sym
->components
);
2494 gfc_free_expr (sym
->value
);
2496 gfc_free_namelist (sym
->namelist
);
2498 gfc_free_namespace (sym
->formal_ns
);
2500 if (!sym
->attr
.generic_copy
)
2501 gfc_free_interface (sym
->generic
);
2503 gfc_free_formal_arglist (sym
->formal
);
2505 gfc_free_namespace (sym
->f2k_derived
);
2511 /* Decrease the reference counter and free memory when we reach zero. */
2514 gfc_release_symbol (gfc_symbol
*sym
)
2519 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 2)
2521 /* As formal_ns contains a reference to sym, delete formal_ns just
2522 before the deletion of sym. */
2523 gfc_namespace
*ns
= sym
->formal_ns
;
2524 sym
->formal_ns
= NULL
;
2525 gfc_free_namespace (ns
);
2532 gcc_assert (sym
->refs
== 0);
2533 gfc_free_symbol (sym
);
2537 /* Allocate and initialize a new symbol node. */
2540 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2544 p
= XCNEW (gfc_symbol
);
2546 gfc_clear_ts (&p
->ts
);
2547 gfc_clear_attr (&p
->attr
);
2550 p
->declared_at
= gfc_current_locus
;
2552 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2553 gfc_internal_error ("new_symbol(): Symbol name too long");
2555 p
->name
= gfc_get_string (name
);
2557 /* Make sure flags for symbol being C bound are clear initially. */
2558 p
->attr
.is_bind_c
= 0;
2559 p
->attr
.is_iso_c
= 0;
2561 /* Clear the ptrs we may need. */
2562 p
->common_block
= NULL
;
2563 p
->f2k_derived
= NULL
;
2570 /* Generate an error if a symbol is ambiguous. */
2573 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2576 if (st
->n
.sym
->module
)
2577 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2578 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2580 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2581 "from current program unit", name
, st
->n
.sym
->name
);
2585 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2586 selector on the stack. If yes, replace it by the corresponding temporary. */
2589 select_type_insert_tmp (gfc_symtree
**st
)
2591 gfc_select_type_stack
*stack
= select_type_stack
;
2592 for (; stack
; stack
= stack
->prev
)
2593 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2598 /* Look for a symtree in the current procedure -- that is, go up to
2599 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2602 gfc_find_symtree_in_proc (const char* name
, gfc_namespace
* ns
)
2606 gfc_symtree
* st
= gfc_find_symtree (ns
->sym_root
, name
);
2610 if (!ns
->construct_entities
)
2619 /* Search for a symtree starting in the current namespace, resorting to
2620 any parent namespaces if requested by a nonzero parent_flag.
2621 Returns nonzero if the name is ambiguous. */
2624 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2625 gfc_symtree
**result
)
2630 ns
= gfc_current_ns
;
2634 st
= gfc_find_symtree (ns
->sym_root
, name
);
2637 select_type_insert_tmp (&st
);
2640 /* Ambiguous generic interfaces are permitted, as long
2641 as the specific interfaces are different. */
2642 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2644 ambiguous_symbol (name
, st
);
2663 /* Same, but returns the symbol instead. */
2666 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2667 gfc_symbol
**result
)
2672 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2677 *result
= st
->n
.sym
;
2683 /* Save symbol with the information necessary to back it out. */
2686 save_symbol_data (gfc_symbol
*sym
)
2689 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2692 sym
->old_symbol
= XCNEW (gfc_symbol
);
2693 *(sym
->old_symbol
) = *sym
;
2695 sym
->tlink
= changed_syms
;
2700 /* Given a name, find a symbol, or create it if it does not exist yet
2701 in the current namespace. If the symbol is found we make sure that
2704 The integer return code indicates
2706 1 The symbol name was ambiguous
2707 2 The name meant to be established was already host associated.
2709 So if the return value is nonzero, then an error was issued. */
2712 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2713 bool allow_subroutine
)
2718 /* This doesn't usually happen during resolution. */
2720 ns
= gfc_current_ns
;
2722 /* Try to find the symbol in ns. */
2723 st
= gfc_find_symtree (ns
->sym_root
, name
);
2727 /* If not there, create a new symbol. */
2728 p
= gfc_new_symbol (name
, ns
);
2730 /* Add to the list of tentative symbols. */
2731 p
->old_symbol
= NULL
;
2732 p
->tlink
= changed_syms
;
2737 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2744 /* Make sure the existing symbol is OK. Ambiguous
2745 generic interfaces are permitted, as long as the
2746 specific interfaces are different. */
2747 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2749 ambiguous_symbol (name
, st
);
2754 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2755 && !(allow_subroutine
&& p
->attr
.subroutine
)
2756 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2757 && (ns
->has_import_set
|| p
->attr
.imported
)))
2759 /* Symbol is from another namespace. */
2760 gfc_error ("Symbol '%s' at %C has already been host associated",
2767 /* Copy in case this symbol is changed. */
2768 save_symbol_data (p
);
2777 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2782 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2787 *result
= st
->n
.sym
;
2794 /* Subroutine that searches for a symbol, creating it if it doesn't
2795 exist, but tries to host-associate the symbol if possible. */
2798 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2803 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2807 save_symbol_data (st
->n
.sym
);
2812 if (gfc_current_ns
->parent
!= NULL
)
2814 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2825 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2830 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2835 i
= gfc_get_ha_sym_tree (name
, &st
);
2838 *result
= st
->n
.sym
;
2845 /* Undoes all the changes made to symbols in the current statement.
2846 This subroutine is made simpler due to the fact that attributes are
2847 never removed once added. */
2850 gfc_undo_symbols (void)
2852 gfc_symbol
*p
, *q
, *old
;
2853 tentative_tbp
*tbp
, *tbq
;
2855 for (p
= changed_syms
; p
; p
= q
)
2861 /* Symbol was new. */
2862 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
2864 /* If the symbol was added to any common block, it
2865 needs to be removed to stop the resolver looking
2866 for a (possibly) dead symbol. */
2868 if (p
->common_block
->head
== p
)
2869 p
->common_block
->head
= p
->common_next
;
2872 gfc_symbol
*cparent
, *csym
;
2874 cparent
= p
->common_block
->head
;
2875 csym
= cparent
->common_next
;
2880 csym
= csym
->common_next
;
2883 gcc_assert(cparent
->common_next
== p
);
2885 cparent
->common_next
= csym
->common_next
;
2889 /* The derived type is saved in the symtree with the first
2890 letter capitalized; the all lower-case version to the
2891 derived type contains its associated generic function. */
2892 if (p
->attr
.flavor
== FL_DERIVED
)
2893 gfc_delete_symtree (&p
->ns
->sym_root
, gfc_get_string ("%c%s",
2894 (char) TOUPPER ((unsigned char) p
->name
[0]),
2897 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2899 gfc_release_symbol (p
);
2903 /* Restore previous state of symbol. Just copy simple stuff. */
2905 old
= p
->old_symbol
;
2907 p
->ts
.type
= old
->ts
.type
;
2908 p
->ts
.kind
= old
->ts
.kind
;
2910 p
->attr
= old
->attr
;
2912 if (p
->value
!= old
->value
)
2914 gfc_free_expr (old
->value
);
2918 if (p
->as
!= old
->as
)
2921 gfc_free_array_spec (p
->as
);
2925 p
->generic
= old
->generic
;
2926 p
->component_access
= old
->component_access
;
2928 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2930 gfc_free_namelist (p
->namelist
);
2935 if (p
->namelist_tail
!= old
->namelist_tail
)
2937 gfc_free_namelist (old
->namelist_tail
);
2938 old
->namelist_tail
->next
= NULL
;
2942 p
->namelist_tail
= old
->namelist_tail
;
2944 if (p
->formal
!= old
->formal
)
2946 gfc_free_formal_arglist (p
->formal
);
2947 p
->formal
= old
->formal
;
2950 free (p
->old_symbol
);
2951 p
->old_symbol
= NULL
;
2955 changed_syms
= NULL
;
2957 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2960 /* Procedure is already marked `error' by default. */
2963 tentative_tbp_list
= NULL
;
2967 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2968 components of old_symbol that might need deallocation are the "allocatables"
2969 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2970 namelist_tail. In case these differ between old_symbol and sym, it's just
2971 because sym->namelist has gotten a few more items. */
2974 free_old_symbol (gfc_symbol
*sym
)
2977 if (sym
->old_symbol
== NULL
)
2980 if (sym
->old_symbol
->as
!= sym
->as
)
2981 gfc_free_array_spec (sym
->old_symbol
->as
);
2983 if (sym
->old_symbol
->value
!= sym
->value
)
2984 gfc_free_expr (sym
->old_symbol
->value
);
2986 if (sym
->old_symbol
->formal
!= sym
->formal
)
2987 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2989 free (sym
->old_symbol
);
2990 sym
->old_symbol
= NULL
;
2994 /* Makes the changes made in the current statement permanent-- gets
2995 rid of undo information. */
2998 gfc_commit_symbols (void)
3001 tentative_tbp
*tbp
, *tbq
;
3003 for (p
= changed_syms
; p
; p
= q
)
3009 free_old_symbol (p
);
3011 changed_syms
= NULL
;
3013 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
3016 tbp
->proc
->error
= 0;
3019 tentative_tbp_list
= NULL
;
3023 /* Makes the changes made in one symbol permanent -- gets rid of undo
3027 gfc_commit_symbol (gfc_symbol
*sym
)
3031 if (changed_syms
== sym
)
3032 changed_syms
= sym
->tlink
;
3035 for (p
= changed_syms
; p
; p
= p
->tlink
)
3036 if (p
->tlink
== sym
)
3038 p
->tlink
= sym
->tlink
;
3047 free_old_symbol (sym
);
3051 /* Recursively free trees containing type-bound procedures. */
3054 free_tb_tree (gfc_symtree
*t
)
3059 free_tb_tree (t
->left
);
3060 free_tb_tree (t
->right
);
3062 /* TODO: Free type-bound procedure structs themselves; probably needs some
3063 sort of ref-counting mechanism. */
3069 /* Recursive function that deletes an entire tree and all the common
3070 head structures it points to. */
3073 free_common_tree (gfc_symtree
* common_tree
)
3075 if (common_tree
== NULL
)
3078 free_common_tree (common_tree
->left
);
3079 free_common_tree (common_tree
->right
);
3085 /* Recursive function that deletes an entire tree and all the user
3086 operator nodes that it contains. */
3089 free_uop_tree (gfc_symtree
*uop_tree
)
3091 if (uop_tree
== NULL
)
3094 free_uop_tree (uop_tree
->left
);
3095 free_uop_tree (uop_tree
->right
);
3097 gfc_free_interface (uop_tree
->n
.uop
->op
);
3098 free (uop_tree
->n
.uop
);
3103 /* Recursive function that deletes an entire tree and all the symbols
3104 that it contains. */
3107 free_sym_tree (gfc_symtree
*sym_tree
)
3109 if (sym_tree
== NULL
)
3112 free_sym_tree (sym_tree
->left
);
3113 free_sym_tree (sym_tree
->right
);
3115 gfc_release_symbol (sym_tree
->n
.sym
);
3120 /* Free the derived type list. */
3123 gfc_free_dt_list (void)
3125 gfc_dt_list
*dt
, *n
;
3127 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3133 gfc_derived_types
= NULL
;
3137 /* Free the gfc_equiv_info's. */
3140 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3144 gfc_free_equiv_infos (s
->next
);
3149 /* Free the gfc_equiv_lists. */
3152 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3156 gfc_free_equiv_lists (l
->next
);
3157 gfc_free_equiv_infos (l
->equiv
);
3162 /* Free a finalizer procedure list. */
3165 gfc_free_finalizer (gfc_finalizer
* el
)
3169 gfc_release_symbol (el
->proc_sym
);
3175 gfc_free_finalizer_list (gfc_finalizer
* list
)
3179 gfc_finalizer
* current
= list
;
3181 gfc_free_finalizer (current
);
3186 /* Create a new gfc_charlen structure and add it to a namespace.
3187 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3190 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3193 cl
= gfc_get_charlen ();
3198 /* Put into namespace, but don't allow reject_statement
3199 to free it if old_cl is given. */
3200 gfc_charlen
**prev
= &ns
->cl_list
;
3201 cl
->next
= ns
->old_cl_list
;
3202 while (*prev
!= ns
->old_cl_list
)
3203 prev
= &(*prev
)->next
;
3205 ns
->old_cl_list
= cl
;
3206 cl
->length
= gfc_copy_expr (old_cl
->length
);
3207 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3208 cl
->backend_decl
= old_cl
->backend_decl
;
3209 cl
->passed_length
= old_cl
->passed_length
;
3210 cl
->resolved
= old_cl
->resolved
;
3214 /* Put into namespace. */
3215 cl
->next
= ns
->cl_list
;
3223 /* Free the charlen list from cl to end (end is not freed).
3224 Free the whole list if end is NULL. */
3227 gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3231 for (; cl
!= end
; cl
= cl2
)
3236 gfc_free_expr (cl
->length
);
3242 /* Free entry list structs. */
3245 free_entry_list (gfc_entry_list
*el
)
3247 gfc_entry_list
*next
;
3254 free_entry_list (next
);
3258 /* Free a namespace structure and everything below it. Interface
3259 lists associated with intrinsic operators are not freed. These are
3260 taken care of when a specific name is freed. */
3263 gfc_free_namespace (gfc_namespace
*ns
)
3265 gfc_namespace
*p
, *q
;
3274 gcc_assert (ns
->refs
== 0);
3276 gfc_free_statements (ns
->code
);
3278 free_sym_tree (ns
->sym_root
);
3279 free_uop_tree (ns
->uop_root
);
3280 free_common_tree (ns
->common_root
);
3281 free_tb_tree (ns
->tb_sym_root
);
3282 free_tb_tree (ns
->tb_uop_root
);
3283 gfc_free_finalizer_list (ns
->finalizers
);
3284 gfc_free_charlen (ns
->cl_list
, NULL
);
3285 free_st_labels (ns
->st_labels
);
3287 free_entry_list (ns
->entries
);
3288 gfc_free_equiv (ns
->equiv
);
3289 gfc_free_equiv_lists (ns
->equiv_lists
);
3290 gfc_free_use_stmts (ns
->use_stmts
);
3292 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3293 gfc_free_interface (ns
->op
[i
]);
3295 gfc_free_data (ns
->data
);
3299 /* Recursively free any contained namespaces. */
3304 gfc_free_namespace (q
);
3310 gfc_symbol_init_2 (void)
3313 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3318 gfc_symbol_done_2 (void)
3321 gfc_free_namespace (gfc_current_ns
);
3322 gfc_current_ns
= NULL
;
3323 gfc_free_dt_list ();
3327 /* Count how many nodes a symtree has. */
3330 count_st_nodes (const gfc_symtree
*st
)
3336 nodes
= count_st_nodes (st
->left
);
3338 nodes
+= count_st_nodes (st
->right
);
3344 /* Convert symtree tree into symtree vector. */
3347 fill_st_vector (gfc_symtree
*st
, gfc_symtree
**st_vec
, unsigned node_cntr
)
3352 node_cntr
= fill_st_vector (st
->left
, st_vec
, node_cntr
);
3353 st_vec
[node_cntr
++] = st
;
3354 node_cntr
= fill_st_vector (st
->right
, st_vec
, node_cntr
);
3360 /* Traverse namespace. As the functions might modify the symtree, we store the
3361 symtree as a vector and operate on this vector. Note: We assume that
3362 sym_func or st_func never deletes nodes from the symtree - only adding is
3363 allowed. Additionally, newly added nodes are not traversed. */
3366 do_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*),
3367 void (*sym_func
) (gfc_symbol
*))
3369 gfc_symtree
**st_vec
;
3370 unsigned nodes
, i
, node_cntr
;
3372 gcc_assert ((st_func
&& !sym_func
) || (!st_func
&& sym_func
));
3373 nodes
= count_st_nodes (st
);
3374 st_vec
= XALLOCAVEC (gfc_symtree
*, nodes
);
3376 fill_st_vector (st
, st_vec
, node_cntr
);
3381 for (i
= 0; i
< nodes
; i
++)
3382 st_vec
[i
]->n
.sym
->mark
= 0;
3383 for (i
= 0; i
< nodes
; i
++)
3384 if (!st_vec
[i
]->n
.sym
->mark
)
3386 (*sym_func
) (st_vec
[i
]->n
.sym
);
3387 st_vec
[i
]->n
.sym
->mark
= 1;
3391 for (i
= 0; i
< nodes
; i
++)
3392 (*st_func
) (st_vec
[i
]);
3396 /* Recursively traverse the symtree nodes. */
3399 gfc_traverse_symtree (gfc_symtree
*st
, void (*st_func
) (gfc_symtree
*))
3401 do_traverse_symtree (st
, st_func
, NULL
);
3405 /* Call a given function for all symbols in the namespace. We take
3406 care that each gfc_symbol node is called exactly once. */
3409 gfc_traverse_ns (gfc_namespace
*ns
, void (*sym_func
) (gfc_symbol
*))
3411 do_traverse_symtree (ns
->sym_root
, NULL
, sym_func
);
3415 /* Return TRUE when name is the name of an intrinsic type. */
3418 gfc_is_intrinsic_typename (const char *name
)
3420 if (strcmp (name
, "integer") == 0
3421 || strcmp (name
, "real") == 0
3422 || strcmp (name
, "character") == 0
3423 || strcmp (name
, "logical") == 0
3424 || strcmp (name
, "complex") == 0
3425 || strcmp (name
, "doubleprecision") == 0
3426 || strcmp (name
, "doublecomplex") == 0)
3433 /* Return TRUE if the symbol is an automatic variable. */
3436 gfc_is_var_automatic (gfc_symbol
*sym
)
3438 /* Pointer and allocatable variables are never automatic. */
3439 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3441 /* Check for arrays with non-constant size. */
3442 if (sym
->attr
.dimension
&& sym
->as
3443 && !gfc_is_compile_time_shape (sym
->as
))
3445 /* Check for non-constant length character variables. */
3446 if (sym
->ts
.type
== BT_CHARACTER
3448 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3453 /* Given a symbol, mark it as SAVEd if it is allowed. */
3456 save_symbol (gfc_symbol
*sym
)
3459 if (sym
->attr
.use_assoc
)
3462 if (sym
->attr
.in_common
3465 || sym
->attr
.flavor
!= FL_VARIABLE
)
3467 /* Automatic objects are not saved. */
3468 if (gfc_is_var_automatic (sym
))
3470 gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
, &sym
->declared_at
);
3474 /* Mark those symbols which can be SAVEd as such. */
3477 gfc_save_all (gfc_namespace
*ns
)
3479 gfc_traverse_ns (ns
, save_symbol
);
3483 /* Make sure that no changes to symbols are pending. */
3486 gfc_enforce_clean_symbol_state(void)
3488 gcc_assert (changed_syms
== NULL
);
3492 /************** Global symbol handling ************/
3495 /* Search a tree for the global symbol. */
3498 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3507 c
= strcmp (name
, symbol
->name
);
3511 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3518 /* Compare two global symbols. Used for managing the BB tree. */
3521 gsym_compare (void *_s1
, void *_s2
)
3523 gfc_gsymbol
*s1
, *s2
;
3525 s1
= (gfc_gsymbol
*) _s1
;
3526 s2
= (gfc_gsymbol
*) _s2
;
3527 return strcmp (s1
->name
, s2
->name
);
3531 /* Get a global symbol, creating it if it doesn't exist. */
3534 gfc_get_gsymbol (const char *name
)
3538 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3542 s
= XCNEW (gfc_gsymbol
);
3543 s
->type
= GSYM_UNKNOWN
;
3544 s
->name
= gfc_get_string (name
);
3546 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3553 get_iso_c_binding_dt (int sym_id
)
3555 gfc_dt_list
*dt_list
;
3557 dt_list
= gfc_derived_types
;
3559 /* Loop through the derived types in the name list, searching for
3560 the desired symbol from iso_c_binding. Search the parent namespaces
3561 if necessary and requested to (parent_flag). */
3562 while (dt_list
!= NULL
)
3564 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3565 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3566 return dt_list
->derived
;
3568 dt_list
= dt_list
->next
;
3575 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3576 with C. This is necessary for any derived type that is BIND(C) and for
3577 derived types that are parameters to functions that are BIND(C). All
3578 fields of the derived type are required to be interoperable, and are tested
3579 for such. If an error occurs, the errors are reported here, allowing for
3580 multiple errors to be handled for a single derived type. */
3583 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3585 gfc_component
*curr_comp
= NULL
;
3586 gfc_try is_c_interop
= FAILURE
;
3587 gfc_try retval
= SUCCESS
;
3589 if (derived_sym
== NULL
)
3590 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3591 "unexpectedly NULL");
3593 /* If we've already looked at this derived symbol, do not look at it again
3594 so we don't repeat warnings/errors. */
3595 if (derived_sym
->ts
.is_c_interop
)
3598 /* The derived type must have the BIND attribute to be interoperable
3599 J3/04-007, Section 15.2.3. */
3600 if (derived_sym
->attr
.is_bind_c
!= 1)
3602 derived_sym
->ts
.is_c_interop
= 0;
3603 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3604 "attribute to be C interoperable", derived_sym
->name
,
3605 &(derived_sym
->declared_at
));
3609 curr_comp
= derived_sym
->components
;
3611 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3612 empty struct. Section 15.2 in Fortran 2003 states: "The following
3613 subclauses define the conditions under which a Fortran entity is
3614 interoperable. If a Fortran entity is interoperable, an equivalent
3615 entity may be defined by means of C and the Fortran entity is said
3616 to be interoperable with the C entity. There does not have to be such
3617 an interoperating C entity."
3619 if (curr_comp
== NULL
)
3621 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3622 "and may be inaccessible by the C companion processor",
3623 derived_sym
->name
, &(derived_sym
->declared_at
));
3624 derived_sym
->ts
.is_c_interop
= 1;
3625 derived_sym
->attr
.is_bind_c
= 1;
3630 /* Initialize the derived type as being C interoperable.
3631 If we find an error in the components, this will be set false. */
3632 derived_sym
->ts
.is_c_interop
= 1;
3634 /* Loop through the list of components to verify that the kind of
3635 each is a C interoperable type. */
3638 /* The components cannot be pointers (fortran sense).
3639 J3/04-007, Section 15.2.3, C1505. */
3640 if (curr_comp
->attr
.pointer
!= 0)
3642 gfc_error ("Component '%s' at %L cannot have the "
3643 "POINTER attribute because it is a member "
3644 "of the BIND(C) derived type '%s' at %L",
3645 curr_comp
->name
, &(curr_comp
->loc
),
3646 derived_sym
->name
, &(derived_sym
->declared_at
));
3650 if (curr_comp
->attr
.proc_pointer
!= 0)
3652 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3653 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3654 &curr_comp
->loc
, derived_sym
->name
,
3655 &derived_sym
->declared_at
);
3659 /* The components cannot be allocatable.
3660 J3/04-007, Section 15.2.3, C1505. */
3661 if (curr_comp
->attr
.allocatable
!= 0)
3663 gfc_error ("Component '%s' at %L cannot have the "
3664 "ALLOCATABLE attribute because it is a member "
3665 "of the BIND(C) derived type '%s' at %L",
3666 curr_comp
->name
, &(curr_comp
->loc
),
3667 derived_sym
->name
, &(derived_sym
->declared_at
));
3671 /* BIND(C) derived types must have interoperable components. */
3672 if (curr_comp
->ts
.type
== BT_DERIVED
3673 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3674 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3676 /* This should be allowed; the draft says a derived-type can not
3677 have type parameters if it is has the BIND attribute. Type
3678 parameters seem to be for making parameterized derived types.
3679 There's no need to verify the type if it is c_ptr/c_funptr. */
3680 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3684 /* Grab the typespec for the given component and test the kind. */
3685 is_c_interop
= gfc_verify_c_interop (&(curr_comp
->ts
));
3687 if (is_c_interop
!= SUCCESS
)
3689 /* Report warning and continue since not fatal. The
3690 draft does specify a constraint that requires all fields
3691 to interoperate, but if the user says real(4), etc., it
3692 may interoperate with *something* in C, but the compiler
3693 most likely won't know exactly what. Further, it may not
3694 interoperate with the same data type(s) in C if the user
3695 recompiles with different flags (e.g., -m32 and -m64 on
3696 x86_64 and using integer(4) to claim interop with a
3698 if (derived_sym
->attr
.is_bind_c
== 1
3699 && gfc_option
.warn_c_binding_type
)
3700 /* If the derived type is bind(c), all fields must be
3702 gfc_warning ("Component '%s' in derived type '%s' at %L "
3703 "may not be C interoperable, even though "
3704 "derived type '%s' is BIND(C)",
3705 curr_comp
->name
, derived_sym
->name
,
3706 &(curr_comp
->loc
), derived_sym
->name
);
3707 else if (gfc_option
.warn_c_binding_type
)
3708 /* If derived type is param to bind(c) routine, or to one
3709 of the iso_c_binding procs, it must be interoperable, so
3710 all fields must interop too. */
3711 gfc_warning ("Component '%s' in derived type '%s' at %L "
3712 "may not be C interoperable",
3713 curr_comp
->name
, derived_sym
->name
,
3718 curr_comp
= curr_comp
->next
;
3719 } while (curr_comp
!= NULL
);
3722 /* Make sure we don't have conflicts with the attributes. */
3723 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3725 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3726 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3727 &(derived_sym
->declared_at
));
3731 if (derived_sym
->attr
.sequence
!= 0)
3733 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3734 "attribute because it is BIND(C)", derived_sym
->name
,
3735 &(derived_sym
->declared_at
));
3739 /* Mark the derived type as not being C interoperable if we found an
3740 error. If there were only warnings, proceed with the assumption
3741 it's interoperable. */
3742 if (retval
== FAILURE
)
3743 derived_sym
->ts
.is_c_interop
= 0;
3749 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3752 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3753 const char *module_name
)
3755 gfc_symtree
*tmp_symtree
;
3756 gfc_symbol
*tmp_sym
;
3759 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3761 if (tmp_symtree
!= NULL
)
3762 tmp_sym
= tmp_symtree
->n
.sym
;
3766 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3767 "create symbol for %s", ptr_name
);
3770 tmp_sym
->ts
.is_c_interop
= 1;
3771 tmp_sym
->attr
.is_c_interop
= 1;
3772 tmp_sym
->ts
.is_iso_c
= 1;
3773 tmp_sym
->ts
.type
= BT_DERIVED
;
3774 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3776 /* The c_ptr and c_funptr derived types will provide the
3777 definition for c_null_ptr and c_null_funptr, respectively. */
3778 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3779 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3781 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3782 if (tmp_sym
->ts
.u
.derived
== NULL
)
3784 /* This can occur if the user forgot to declare c_ptr or
3785 c_funptr and they're trying to use one of the procedures
3786 that has arg(s) of the missing type. In this case, a
3787 regular version of the thing should have been put in the
3790 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3791 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3792 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3795 tmp_sym
->ts
.u
.derived
=
3796 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3797 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3800 /* Module name is some mangled version of iso_c_binding. */
3801 tmp_sym
->module
= gfc_get_string (module_name
);
3803 /* Say it's from the iso_c_binding module. */
3804 tmp_sym
->attr
.is_iso_c
= 1;
3806 tmp_sym
->attr
.use_assoc
= 1;
3807 tmp_sym
->attr
.is_bind_c
= 1;
3808 /* Since we never generate a call to this symbol, don't set the
3811 /* Set the c_address field of c_null_ptr and c_null_funptr to
3812 the value of NULL. */
3813 tmp_sym
->value
= gfc_get_expr ();
3814 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3815 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3816 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
3817 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
3818 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
3819 c
->expr
= gfc_get_expr ();
3820 c
->expr
->expr_type
= EXPR_NULL
;
3821 c
->expr
->ts
.is_iso_c
= 1;
3827 /* Add a formal argument, gfc_formal_arglist, to the
3828 end of the given list of arguments. Set the reference to the
3829 provided symbol, param_sym, in the argument. */
3832 add_formal_arg (gfc_formal_arglist
**head
,
3833 gfc_formal_arglist
**tail
,
3834 gfc_formal_arglist
*formal_arg
,
3835 gfc_symbol
*param_sym
)
3837 /* Put in list, either as first arg or at the tail (curr arg). */
3839 *head
= *tail
= formal_arg
;
3842 (*tail
)->next
= formal_arg
;
3843 (*tail
) = formal_arg
;
3846 (*tail
)->sym
= param_sym
;
3847 (*tail
)->next
= NULL
;
3853 /* Generates a symbol representing the CPTR argument to an
3854 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3855 CPTR and add it to the provided argument list. */
3858 gen_cptr_param (gfc_formal_arglist
**head
,
3859 gfc_formal_arglist
**tail
,
3860 const char *module_name
,
3861 gfc_namespace
*ns
, const char *c_ptr_name
,
3864 gfc_symbol
*param_sym
= NULL
;
3865 gfc_symbol
*c_ptr_sym
= NULL
;
3866 gfc_symtree
*param_symtree
= NULL
;
3867 gfc_formal_arglist
*formal_arg
= NULL
;
3868 const char *c_ptr_in
;
3869 const char *c_ptr_type
= NULL
;
3871 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3872 c_ptr_type
= "c_funptr";
3874 c_ptr_type
= "c_ptr";
3876 if(c_ptr_name
== NULL
)
3877 c_ptr_in
= "gfc_cptr__";
3879 c_ptr_in
= c_ptr_name
;
3880 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
, false);
3881 if (param_symtree
!= NULL
)
3882 param_sym
= param_symtree
->n
.sym
;
3884 gfc_internal_error ("gen_cptr_param(): Unable to "
3885 "create symbol for %s", c_ptr_in
);
3887 /* Set up the appropriate fields for the new c_ptr param sym. */
3889 param_sym
->attr
.flavor
= FL_DERIVED
;
3890 param_sym
->ts
.type
= BT_DERIVED
;
3891 param_sym
->attr
.intent
= INTENT_IN
;
3892 param_sym
->attr
.dummy
= 1;
3894 /* This will pass the ptr to the iso_c routines as a (void *). */
3895 param_sym
->attr
.value
= 1;
3896 param_sym
->attr
.use_assoc
= 1;
3898 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3900 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3901 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3903 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3904 if (c_ptr_sym
== NULL
)
3906 /* This can happen if the user did not define c_ptr but they are
3907 trying to use one of the iso_c_binding functions that need it. */
3908 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3909 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3910 (const char *)c_ptr_type
);
3912 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3913 (const char *)c_ptr_type
);
3915 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3918 param_sym
->ts
.u
.derived
= c_ptr_sym
;
3919 param_sym
->module
= gfc_get_string (module_name
);
3921 /* Make new formal arg. */
3922 formal_arg
= gfc_get_formal_arglist ();
3923 /* Add arg to list of formal args (the CPTR arg). */
3924 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3926 /* Validate changes. */
3927 gfc_commit_symbol (param_sym
);
3931 /* Generates a symbol representing the FPTR argument to an
3932 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3933 FPTR and add it to the provided argument list. */
3936 gen_fptr_param (gfc_formal_arglist
**head
,
3937 gfc_formal_arglist
**tail
,
3938 const char *module_name
,
3939 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3941 gfc_symbol
*param_sym
= NULL
;
3942 gfc_symtree
*param_symtree
= NULL
;
3943 gfc_formal_arglist
*formal_arg
= NULL
;
3944 const char *f_ptr_out
= "gfc_fptr__";
3946 if (f_ptr_name
!= NULL
)
3947 f_ptr_out
= f_ptr_name
;
3949 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
, false);
3950 if (param_symtree
!= NULL
)
3951 param_sym
= param_symtree
->n
.sym
;
3953 gfc_internal_error ("generateFPtrParam(): Unable to "
3954 "create symbol for %s", f_ptr_out
);
3956 /* Set up the necessary fields for the fptr output param sym. */
3959 param_sym
->attr
.proc_pointer
= 1;
3961 param_sym
->attr
.pointer
= 1;
3962 param_sym
->attr
.dummy
= 1;
3963 param_sym
->attr
.use_assoc
= 1;
3965 /* ISO C Binding type to allow any pointer type as actual param. */
3966 param_sym
->ts
.type
= BT_VOID
;
3967 param_sym
->module
= gfc_get_string (module_name
);
3970 formal_arg
= gfc_get_formal_arglist ();
3971 /* Add arg to list of formal args. */
3972 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3974 /* Validate changes. */
3975 gfc_commit_symbol (param_sym
);
3979 /* Generates a symbol representing the optional SHAPE argument for the
3980 iso_c_binding c_f_pointer() procedure. Also, create a
3981 gfc_formal_arglist for the SHAPE and add it to the provided
3985 gen_shape_param (gfc_formal_arglist
**head
,
3986 gfc_formal_arglist
**tail
,
3987 const char *module_name
,
3988 gfc_namespace
*ns
, const char *shape_param_name
)
3990 gfc_symbol
*param_sym
= NULL
;
3991 gfc_symtree
*param_symtree
= NULL
;
3992 gfc_formal_arglist
*formal_arg
= NULL
;
3993 const char *shape_param
= "gfc_shape_array__";
3995 if (shape_param_name
!= NULL
)
3996 shape_param
= shape_param_name
;
3998 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
, false);
3999 if (param_symtree
!= NULL
)
4000 param_sym
= param_symtree
->n
.sym
;
4002 gfc_internal_error ("generateShapeParam(): Unable to "
4003 "create symbol for %s", shape_param
);
4005 /* Set up the necessary fields for the shape input param sym. */
4007 param_sym
->attr
.dummy
= 1;
4008 param_sym
->attr
.use_assoc
= 1;
4010 /* Integer array, rank 1, describing the shape of the object. Make it's
4011 type BT_VOID initially so we can accept any type/kind combination of
4012 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
4013 of BT_INTEGER type. */
4014 param_sym
->ts
.type
= BT_VOID
;
4016 /* Initialize the kind to default integer. However, it will be overridden
4017 during resolution to match the kind of the SHAPE parameter given as
4018 the actual argument (to allow for any valid integer kind). */
4019 param_sym
->ts
.kind
= gfc_default_integer_kind
;
4020 param_sym
->as
= gfc_get_array_spec ();
4022 param_sym
->as
->rank
= 1;
4023 param_sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
4026 /* The extent is unknown until we get it. The length give us
4027 the rank the incoming pointer. */
4028 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
4030 /* The arg is also optional; it is required iff the second arg
4031 (fptr) is to an array, otherwise, it's ignored. */
4032 param_sym
->attr
.optional
= 1;
4033 param_sym
->attr
.intent
= INTENT_IN
;
4034 param_sym
->attr
.dimension
= 1;
4035 param_sym
->module
= gfc_get_string (module_name
);
4038 formal_arg
= gfc_get_formal_arglist ();
4039 /* Add arg to list of formal args. */
4040 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
4042 /* Validate changes. */
4043 gfc_commit_symbol (param_sym
);
4047 /* Add a procedure interface to the given symbol (i.e., store a
4048 reference to the list of formal arguments). */
4051 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
4052 gfc_formal_arglist
*formal
)
4055 sym
->formal
= formal
;
4056 sym
->attr
.if_source
= source
;
4060 /* Copy the formal args from an existing symbol, src, into a new
4061 symbol, dest. New formal args are created, and the description of
4062 each arg is set according to the existing ones. This function is
4063 used when creating procedure declaration variables from a procedure
4064 declaration statement (see match_proc_decl()) to create the formal
4065 args based on the args of a given named interface. */
4068 gfc_copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
4070 gfc_formal_arglist
*head
= NULL
;
4071 gfc_formal_arglist
*tail
= NULL
;
4072 gfc_formal_arglist
*formal_arg
= NULL
;
4073 gfc_formal_arglist
*curr_arg
= NULL
;
4074 gfc_formal_arglist
*formal_prev
= NULL
;
4075 /* Save current namespace so we can change it for formal args. */
4076 gfc_namespace
*parent_ns
= gfc_current_ns
;
4078 /* Create a new namespace, which will be the formal ns (namespace
4079 of the formal args). */
4080 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4081 gfc_current_ns
->proc_name
= dest
;
4083 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4085 formal_arg
= gfc_get_formal_arglist ();
4086 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4088 /* May need to copy more info for the symbol. */
4089 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4090 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4091 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4092 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4094 /* If this isn't the first arg, set up the next ptr. For the
4095 last arg built, the formal_arg->next will never get set to
4096 anything other than NULL. */
4097 if (formal_prev
!= NULL
)
4098 formal_prev
->next
= formal_arg
;
4100 formal_arg
->next
= NULL
;
4102 formal_prev
= formal_arg
;
4104 /* Add arg to list of formal args. */
4105 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4107 /* Validate changes. */
4108 gfc_commit_symbol (formal_arg
->sym
);
4111 /* Add the interface to the symbol. */
4112 add_proc_interface (dest
, IFSRC_DECL
, head
);
4114 /* Store the formal namespace information. */
4115 if (dest
->formal
!= NULL
)
4116 /* The current ns should be that for the dest proc. */
4117 dest
->formal_ns
= gfc_current_ns
;
4118 /* Restore the current namespace to what it was on entry. */
4119 gfc_current_ns
= parent_ns
;
4124 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
4126 gfc_formal_arglist
*head
= NULL
;
4127 gfc_formal_arglist
*tail
= NULL
;
4128 gfc_formal_arglist
*formal_arg
= NULL
;
4129 gfc_intrinsic_arg
*curr_arg
= NULL
;
4130 gfc_formal_arglist
*formal_prev
= NULL
;
4131 /* Save current namespace so we can change it for formal args. */
4132 gfc_namespace
*parent_ns
= gfc_current_ns
;
4134 /* Create a new namespace, which will be the formal ns (namespace
4135 of the formal args). */
4136 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4137 gfc_current_ns
->proc_name
= dest
;
4139 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4141 formal_arg
= gfc_get_formal_arglist ();
4142 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4144 /* May need to copy more info for the symbol. */
4145 formal_arg
->sym
->ts
= curr_arg
->ts
;
4146 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4147 formal_arg
->sym
->attr
.value
= curr_arg
->value
;
4148 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4149 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4150 formal_arg
->sym
->attr
.dummy
= 1;
4152 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4153 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4155 /* If this isn't the first arg, set up the next ptr. For the
4156 last arg built, the formal_arg->next will never get set to
4157 anything other than NULL. */
4158 if (formal_prev
!= NULL
)
4159 formal_prev
->next
= formal_arg
;
4161 formal_arg
->next
= NULL
;
4163 formal_prev
= formal_arg
;
4165 /* Add arg to list of formal args. */
4166 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4168 /* Validate changes. */
4169 gfc_commit_symbol (formal_arg
->sym
);
4172 /* Add the interface to the symbol. */
4173 add_proc_interface (dest
, IFSRC_DECL
, head
);
4175 /* Store the formal namespace information. */
4176 if (dest
->formal
!= NULL
)
4177 /* The current ns should be that for the dest proc. */
4178 dest
->formal_ns
= gfc_current_ns
;
4179 /* Restore the current namespace to what it was on entry. */
4180 gfc_current_ns
= parent_ns
;
4185 gfc_copy_formal_args_ppc (gfc_component
*dest
, gfc_symbol
*src
)
4187 gfc_formal_arglist
*head
= NULL
;
4188 gfc_formal_arglist
*tail
= NULL
;
4189 gfc_formal_arglist
*formal_arg
= NULL
;
4190 gfc_formal_arglist
*curr_arg
= NULL
;
4191 gfc_formal_arglist
*formal_prev
= NULL
;
4192 /* Save current namespace so we can change it for formal args. */
4193 gfc_namespace
*parent_ns
= gfc_current_ns
;
4195 /* Create a new namespace, which will be the formal ns (namespace
4196 of the formal args). */
4197 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4198 /* TODO: gfc_current_ns->proc_name = dest;*/
4200 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4202 formal_arg
= gfc_get_formal_arglist ();
4203 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4205 /* May need to copy more info for the symbol. */
4206 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4207 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4208 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4209 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4211 /* If this isn't the first arg, set up the next ptr. For the
4212 last arg built, the formal_arg->next will never get set to
4213 anything other than NULL. */
4214 if (formal_prev
!= NULL
)
4215 formal_prev
->next
= formal_arg
;
4217 formal_arg
->next
= NULL
;
4219 formal_prev
= formal_arg
;
4221 /* Add arg to list of formal args. */
4222 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4224 /* Validate changes. */
4225 gfc_commit_symbol (formal_arg
->sym
);
4228 /* Add the interface to the symbol. */
4229 gfc_free_formal_arglist (dest
->formal
);
4230 dest
->formal
= head
;
4231 dest
->attr
.if_source
= IFSRC_DECL
;
4233 /* Store the formal namespace information. */
4234 if (dest
->formal
!= NULL
)
4235 /* The current ns should be that for the dest proc. */
4236 dest
->formal_ns
= gfc_current_ns
;
4237 /* Restore the current namespace to what it was on entry. */
4238 gfc_current_ns
= parent_ns
;
4242 /* Builds the parameter list for the iso_c_binding procedure
4243 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4244 generic version of either the c_f_pointer or c_f_procpointer
4245 functions. The new_proc_sym represents a "resolved" version of the
4246 symbol. The functions are resolved to match the types of their
4247 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4248 something similar to c_f_pointer_i4 if the type of data object fptr
4249 pointed to was a default integer. The actual name of the resolved
4250 procedure symbol is further mangled with the module name, etc., but
4251 the idea holds true. */
4254 build_formal_args (gfc_symbol
*new_proc_sym
,
4255 gfc_symbol
*old_sym
, int add_optional_arg
)
4257 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
4258 gfc_namespace
*parent_ns
= NULL
;
4260 parent_ns
= gfc_current_ns
;
4261 /* Create a new namespace, which will be the formal ns (namespace
4262 of the formal args). */
4263 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
4264 gfc_current_ns
->proc_name
= new_proc_sym
;
4266 /* Generate the params. */
4267 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
4269 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4270 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4271 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4272 gfc_current_ns
, "fptr", 1);
4274 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
4276 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4277 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4278 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4279 gfc_current_ns
, "fptr", 0);
4280 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4281 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
4282 gfc_current_ns
, "shape");
4285 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
4287 /* c_associated has one required arg and one optional; both
4289 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4290 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
4291 if (add_optional_arg
)
4293 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4294 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
4295 /* The last param is optional so mark it as such. */
4296 tail
->sym
->attr
.optional
= 1;
4300 /* Add the interface (store formal args to new_proc_sym). */
4301 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
4303 /* Set up the formal_ns pointer to the one created for the
4304 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4305 new_proc_sym
->formal_ns
= gfc_current_ns
;
4307 gfc_current_ns
= parent_ns
;
4311 std_for_isocbinding_symbol (int id
)
4315 #define NAMED_INTCST(a,b,c,d) \
4318 #include "iso-c-binding.def"
4321 #define NAMED_FUNCTION(a,b,c,d) \
4324 #include "iso-c-binding.def"
4325 #undef NAMED_FUNCTION
4328 return GFC_STD_F2003
;
4332 /* Generate the given set of C interoperable kind objects, or all
4333 interoperable kinds. This function will only be given kind objects
4334 for valid iso_c_binding defined types because this is verified when
4335 the 'use' statement is parsed. If the user gives an 'only' clause,
4336 the specific kinds are looked up; if they don't exist, an error is
4337 reported. If the user does not give an 'only' clause, all
4338 iso_c_binding symbols are generated. If a list of specific kinds
4339 is given, it must have a NULL in the first empty spot to mark the
4344 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4345 const char *local_name
)
4347 const char *const name
= (local_name
&& local_name
[0]) ? local_name
4348 : c_interop_kinds_table
[s
].name
;
4349 gfc_symtree
*tmp_symtree
= NULL
;
4350 gfc_symbol
*tmp_sym
= NULL
;
4353 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4356 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4358 /* Already exists in this scope so don't re-add it. */
4359 if (tmp_symtree
!= NULL
&& (tmp_sym
= tmp_symtree
->n
.sym
) != NULL
4360 && (!tmp_sym
->attr
.generic
4361 || (tmp_sym
= gfc_find_dt_in_generic (tmp_sym
)) != NULL
)
4362 && tmp_sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
4364 if (tmp_sym
->attr
.flavor
== FL_DERIVED
4365 && !get_iso_c_binding_dt (tmp_sym
->intmod_sym_id
))
4367 gfc_dt_list
*dt_list
;
4368 dt_list
= gfc_get_dt_list ();
4369 dt_list
->derived
= tmp_sym
;
4370 dt_list
->next
= gfc_derived_types
;
4371 gfc_derived_types
= dt_list
;
4377 /* Create the sym tree in the current ns. */
4378 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4380 tmp_sym
= tmp_symtree
->n
.sym
;
4382 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4385 /* Say what module this symbol belongs to. */
4386 tmp_sym
->module
= gfc_get_string (mod_name
);
4387 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4388 tmp_sym
->intmod_sym_id
= s
;
4393 #define NAMED_INTCST(a,b,c,d) case a :
4394 #define NAMED_REALCST(a,b,c,d) case a :
4395 #define NAMED_CMPXCST(a,b,c,d) case a :
4396 #define NAMED_LOGCST(a,b,c) case a :
4397 #define NAMED_CHARKNDCST(a,b,c) case a :
4398 #include "iso-c-binding.def"
4400 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4401 c_interop_kinds_table
[s
].value
);
4403 /* Initialize an integer constant expression node. */
4404 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4405 tmp_sym
->ts
.type
= BT_INTEGER
;
4406 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4408 /* Mark this type as a C interoperable one. */
4409 tmp_sym
->ts
.is_c_interop
= 1;
4410 tmp_sym
->ts
.is_iso_c
= 1;
4411 tmp_sym
->value
->ts
.is_c_interop
= 1;
4412 tmp_sym
->value
->ts
.is_iso_c
= 1;
4413 tmp_sym
->attr
.is_c_interop
= 1;
4415 /* Tell what f90 type this c interop kind is valid. */
4416 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4418 /* Say it's from the iso_c_binding module. */
4419 tmp_sym
->attr
.is_iso_c
= 1;
4421 /* Make it use associated. */
4422 tmp_sym
->attr
.use_assoc
= 1;
4426 #define NAMED_CHARCST(a,b,c) case a :
4427 #include "iso-c-binding.def"
4429 /* Initialize an integer constant expression node for the
4430 length of the character. */
4431 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4432 &gfc_current_locus
, NULL
, 1);
4433 tmp_sym
->value
->ts
.is_c_interop
= 1;
4434 tmp_sym
->value
->ts
.is_iso_c
= 1;
4435 tmp_sym
->value
->value
.character
.length
= 1;
4436 tmp_sym
->value
->value
.character
.string
[0]
4437 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4438 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4439 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4442 /* May not need this in both attr and ts, but do need in
4443 attr for writing module file. */
4444 tmp_sym
->attr
.is_c_interop
= 1;
4446 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4447 tmp_sym
->ts
.type
= BT_CHARACTER
;
4449 /* Need to set it to the C_CHAR kind. */
4450 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4452 /* Mark this type as a C interoperable one. */
4453 tmp_sym
->ts
.is_c_interop
= 1;
4454 tmp_sym
->ts
.is_iso_c
= 1;
4456 /* Tell what f90 type this c interop kind is valid. */
4457 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4459 /* Say it's from the iso_c_binding module. */
4460 tmp_sym
->attr
.is_iso_c
= 1;
4462 /* Make it use associated. */
4463 tmp_sym
->attr
.use_assoc
= 1;
4466 case ISOCBINDING_PTR
:
4467 case ISOCBINDING_FUNPTR
:
4469 gfc_interface
*intr
, *head
;
4471 const char *hidden_name
;
4472 gfc_dt_list
**dt_list_ptr
= NULL
;
4473 gfc_component
*tmp_comp
= NULL
;
4474 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
4476 hidden_name
= gfc_get_string ("%c%s",
4477 (char) TOUPPER ((unsigned char) tmp_sym
->name
[0]),
4480 /* Generate real derived type. */
4481 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4484 if (tmp_symtree
!= NULL
)
4486 gfc_get_sym_tree (hidden_name
, gfc_current_ns
, &tmp_symtree
, false);
4488 dt_sym
= tmp_symtree
->n
.sym
;
4492 /* Generate an artificial generic function. */
4493 dt_sym
->name
= gfc_get_string (tmp_sym
->name
);
4494 head
= tmp_sym
->generic
;
4495 intr
= gfc_get_interface ();
4497 intr
->where
= gfc_current_locus
;
4499 tmp_sym
->generic
= intr
;
4501 if (!tmp_sym
->attr
.generic
4502 && gfc_add_generic (&tmp_sym
->attr
, tmp_sym
->name
, NULL
)
4506 if (!tmp_sym
->attr
.function
4507 && gfc_add_function (&tmp_sym
->attr
, tmp_sym
->name
, NULL
)
4511 /* Say what module this symbol belongs to. */
4512 dt_sym
->module
= gfc_get_string (mod_name
);
4513 dt_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4514 dt_sym
->intmod_sym_id
= s
;
4516 /* Initialize an integer constant expression node. */
4517 dt_sym
->attr
.flavor
= FL_DERIVED
;
4518 dt_sym
->ts
.is_c_interop
= 1;
4519 dt_sym
->attr
.is_c_interop
= 1;
4520 dt_sym
->attr
.is_iso_c
= 1;
4521 dt_sym
->ts
.is_iso_c
= 1;
4522 dt_sym
->ts
.type
= BT_DERIVED
;
4524 /* A derived type must have the bind attribute to be
4525 interoperable (J3/04-007, Section 15.2.3), even though
4526 the binding label is not used. */
4527 dt_sym
->attr
.is_bind_c
= 1;
4529 dt_sym
->attr
.referenced
= 1;
4530 dt_sym
->ts
.u
.derived
= dt_sym
;
4532 /* Add the symbol created for the derived type to the current ns. */
4533 dt_list_ptr
= &(gfc_derived_types
);
4534 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4535 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4537 /* There is already at least one derived type in the list, so append
4538 the one we're currently building for c_ptr or c_funptr. */
4539 if (*dt_list_ptr
!= NULL
)
4540 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4541 (*dt_list_ptr
) = gfc_get_dt_list ();
4542 (*dt_list_ptr
)->derived
= dt_sym
;
4543 (*dt_list_ptr
)->next
= NULL
;
4545 /* Set up the component of the derived type, which will be
4546 an integer with kind equal to c_ptr_size. Mangle the name of
4547 the field for the c_address to prevent the curious user from
4548 trying to access it from Fortran. */
4549 sprintf (comp_name
, "__%s_%s", dt_sym
->name
, "c_address");
4550 gfc_add_component (dt_sym
, comp_name
, &tmp_comp
);
4551 if (tmp_comp
== NULL
)
4552 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4553 "create component for c_address");
4555 tmp_comp
->ts
.type
= BT_INTEGER
;
4557 /* Set this because the module will need to read/write this field. */
4558 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4560 /* The kinds for c_ptr and c_funptr are the same. */
4561 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4562 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4564 tmp_comp
->attr
.pointer
= 0;
4565 tmp_comp
->attr
.dimension
= 0;
4567 /* Mark the component as C interoperable. */
4568 tmp_comp
->ts
.is_c_interop
= 1;
4570 /* Make it use associated (iso_c_binding module). */
4571 dt_sym
->attr
.use_assoc
= 1;
4576 case ISOCBINDING_NULL_PTR
:
4577 case ISOCBINDING_NULL_FUNPTR
:
4578 gen_special_c_interop_ptr (s
, name
, mod_name
);
4581 case ISOCBINDING_F_POINTER
:
4582 case ISOCBINDING_ASSOCIATED
:
4583 case ISOCBINDING_LOC
:
4584 case ISOCBINDING_FUNLOC
:
4585 case ISOCBINDING_F_PROCPOINTER
:
4587 tmp_sym
->attr
.proc
= PROC_MODULE
;
4589 /* Use the procedure's name as it is in the iso_c_binding module for
4590 setting the binding label in case the user renamed the symbol. */
4591 tmp_sym
->binding_label
=
4592 gfc_get_string ("%s_%s", mod_name
,
4593 c_interop_kinds_table
[s
].name
);
4594 tmp_sym
->attr
.is_iso_c
= 1;
4595 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4596 tmp_sym
->attr
.subroutine
= 1;
4599 /* TODO! This needs to be finished more for the expr of the
4600 function or something!
4601 This may not need to be here, because trying to do c_loc
4603 if (s
== ISOCBINDING_ASSOCIATED
)
4605 tmp_sym
->attr
.function
= 1;
4606 tmp_sym
->ts
.type
= BT_LOGICAL
;
4607 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4608 tmp_sym
->result
= tmp_sym
;
4612 /* Here, we're taking the simple approach. We're defining
4613 c_loc as an external identifier so the compiler will put
4614 what we expect on the stack for the address we want the
4616 tmp_sym
->ts
.type
= BT_DERIVED
;
4617 if (s
== ISOCBINDING_LOC
)
4618 tmp_sym
->ts
.u
.derived
=
4619 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4621 tmp_sym
->ts
.u
.derived
=
4622 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4624 if (tmp_sym
->ts
.u
.derived
== NULL
)
4626 /* Create the necessary derived type so we can continue
4627 processing the file. */
4628 generate_isocbinding_symbol
4629 (mod_name
, s
== ISOCBINDING_FUNLOC
4630 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4631 (const char *)(s
== ISOCBINDING_FUNLOC
4632 ? "c_funptr" : "c_ptr"));
4633 tmp_sym
->ts
.u
.derived
=
4634 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4635 ? ISOCBINDING_FUNPTR
4639 /* The function result is itself (no result clause). */
4640 tmp_sym
->result
= tmp_sym
;
4641 tmp_sym
->attr
.external
= 1;
4642 tmp_sym
->attr
.use_assoc
= 0;
4643 tmp_sym
->attr
.pure
= 1;
4644 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4645 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4649 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4650 tmp_sym
->attr
.contained
= 0;
4652 /* Try using this builder routine, with the new and old symbols
4653 both being the generic iso_c proc sym being created. This
4654 will create the formal args (and the new namespace for them).
4655 Don't build an arg list for c_loc because we're going to treat
4656 c_loc as an external procedure. */
4657 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4658 /* The 1 says to add any optional args, if applicable. */
4659 build_formal_args (tmp_sym
, tmp_sym
, 1);
4661 /* Set this after setting up the symbol, to prevent error messages. */
4662 tmp_sym
->attr
.use_assoc
= 1;
4664 /* This symbol will not be referenced directly. It will be
4665 resolved to the implementation for the given f90 kind. */
4666 tmp_sym
->attr
.referenced
= 0;
4673 gfc_commit_symbol (tmp_sym
);
4677 /* Creates a new symbol based off of an old iso_c symbol, with a new
4678 binding label. This function can be used to create a new,
4679 resolved, version of a procedure symbol for c_f_pointer or
4680 c_f_procpointer that is based on the generic symbols. A new
4681 parameter list is created for the new symbol using
4682 build_formal_args(). The add_optional_flag specifies whether the
4683 to add the optional SHAPE argument. The new symbol is
4687 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4688 const char *new_binding_label
, int add_optional_arg
)
4690 gfc_symtree
*new_symtree
= NULL
;
4692 /* See if we have a symbol by that name already available, looking
4693 through any parent namespaces. */
4694 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4695 if (new_symtree
!= NULL
)
4696 /* Return the existing symbol. */
4697 return new_symtree
->n
.sym
;
4699 /* Create the symtree/symbol, with attempted host association. */
4700 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4701 if (new_symtree
== NULL
)
4702 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4703 "symtree for '%s'", new_name
);
4705 /* Now fill in the fields of the resolved symbol with the old sym. */
4706 new_symtree
->n
.sym
->binding_label
= new_binding_label
;
4707 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4708 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4709 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4710 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4711 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4712 if (old_sym
->attr
.function
)
4713 new_symtree
->n
.sym
->result
= new_symtree
->n
.sym
;
4714 /* Build the formal arg list. */
4715 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4717 gfc_commit_symbol (new_symtree
->n
.sym
);
4719 return new_symtree
->n
.sym
;
4723 /* Check that a symbol is already typed. If strict is not set, an untyped
4724 symbol is acceptable for non-standard-conforming mode. */
4727 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4728 bool strict
, locus where
)
4732 if (gfc_matching_prefix
)
4735 /* Check for the type and try to give it an implicit one. */
4736 if (sym
->ts
.type
== BT_UNKNOWN
4737 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4741 gfc_error ("Symbol '%s' is used before it is typed at %L",
4746 if (gfc_notify_std (GFC_STD_GNU
,
4747 "Extension: Symbol '%s' is used before"
4748 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4752 /* Everything is ok. */
4757 /* Construct a typebound-procedure structure. Those are stored in a tentative
4758 list and marked `error' until symbols are committed. */
4761 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4763 gfc_typebound_proc
*result
;
4764 tentative_tbp
*list_node
;
4766 result
= XCNEW (gfc_typebound_proc
);
4771 list_node
= XCNEW (tentative_tbp
);
4772 list_node
->next
= tentative_tbp_list
;
4773 list_node
->proc
= result
;
4774 tentative_tbp_list
= list_node
;
4780 /* Get the super-type of a given derived type. */
4783 gfc_get_derived_super_type (gfc_symbol
* derived
)
4785 if (derived
&& derived
->attr
.generic
)
4786 derived
= gfc_find_dt_in_generic (derived
);
4788 if (!derived
->attr
.extension
)
4791 gcc_assert (derived
->components
);
4792 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4793 gcc_assert (derived
->components
->ts
.u
.derived
);
4795 if (derived
->components
->ts
.u
.derived
->attr
.generic
)
4796 return gfc_find_dt_in_generic (derived
->components
->ts
.u
.derived
);
4798 return derived
->components
->ts
.u
.derived
;
4802 /* Get the ultimate super-type of a given derived type. */
4805 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4807 if (!derived
->attr
.extension
)
4810 derived
= gfc_get_derived_super_type (derived
);
4812 if (derived
->attr
.extension
)
4813 return gfc_get_ultimate_derived_super_type (derived
);
4819 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4822 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4824 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4825 t2
= gfc_get_derived_super_type (t2
);
4826 return gfc_compare_derived_types (t1
, t2
);
4830 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4831 If ts1 is nonpolymorphic, ts2 must be the same type.
4832 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4835 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4837 bool is_class1
= (ts1
->type
== BT_CLASS
);
4838 bool is_class2
= (ts2
->type
== BT_CLASS
);
4839 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4840 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4842 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
)
4843 return (ts1
->type
== ts2
->type
);
4845 if (is_derived1
&& is_derived2
)
4846 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4848 if (is_class1
&& is_derived2
)
4849 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4851 else if (is_class1
&& is_class2
)
4852 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4853 ts2
->u
.derived
->components
->ts
.u
.derived
);
4859 /* Find the parent-namespace of the current function. If we're inside
4860 BLOCK constructs, it may not be the current one. */
4863 gfc_find_proc_namespace (gfc_namespace
* ns
)
4865 while (ns
->construct_entities
)
4875 /* Check if an associate-variable should be translated as an `implicit' pointer
4876 internally (if it is associated to a variable and not an array with
4880 gfc_is_associate_pointer (gfc_symbol
* sym
)
4885 if (!sym
->assoc
->variable
)
4888 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_EXPLICIT
)
4896 gfc_find_dt_in_generic (gfc_symbol
*sym
)
4898 gfc_interface
*intr
= NULL
;
4900 if (!sym
|| sym
->attr
.flavor
== FL_DERIVED
)
4903 if (sym
->attr
.generic
)
4904 for (intr
= (sym
? sym
->generic
: NULL
); intr
; intr
= intr
->next
)
4905 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
4907 return intr
? intr
->sym
: NULL
;