1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors
[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
41 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
42 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
43 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
47 const mstring procedures
[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
50 minit ("MODULE-PROC", PROC_MODULE
),
51 minit ("INTERNAL-PROC", PROC_INTERNAL
),
52 minit ("DUMMY-PROC", PROC_DUMMY
),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
59 const mstring intents
[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
62 minit ("IN", INTENT_IN
),
63 minit ("OUT", INTENT_OUT
),
64 minit ("INOUT", INTENT_INOUT
),
68 const mstring access_types
[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
71 minit ("PUBLIC", ACCESS_PUBLIC
),
72 minit ("PRIVATE", ACCESS_PRIVATE
),
76 const mstring ifsrc_types
[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN
),
79 minit ("DECL", IFSRC_DECL
),
80 minit ("BODY", IFSRC_IFBODY
)
83 const mstring save_status
[] =
85 minit ("UNKNOWN", SAVE_NONE
),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order
= 1;
96 gfc_namespace
*gfc_current_ns
;
97 gfc_namespace
*gfc_global_ns_list
;
99 gfc_gsymbol
*gfc_gsym_root
= NULL
;
101 static gfc_symbol
*changed_syms
= NULL
;
103 gfc_dt_list
*gfc_derived_types
;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc
*proc
;
111 struct tentative_tbp
*next
;
115 static tentative_tbp
*tentative_tbp_list
= NULL
;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag
[GFC_LETTERS
];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns
->seen_implicit_none
)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns
->seen_implicit_none
= 1;
141 for (i
= 0; i
< GFC_LETTERS
; i
++)
143 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
144 gfc_current_ns
->set_flag
[i
] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i
= 0; i
< GFC_LETTERS
; i
++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1
, int c2
)
171 for (i
= c1
; i
<= c2
; i
++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec
*ts
)
195 if (gfc_current_ns
->seen_implicit_none
)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i
= 0; i
< GFC_LETTERS
; i
++)
205 if (gfc_current_ns
->set_flag
[i
])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns
->default_type
[i
] = *ts
;
213 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
214 gfc_current_ns
->set_flag
[i
] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
230 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter
< 'a' || letter
> 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name
);
241 return &ns
->default_type
[letter
- 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
254 if (sym
->ts
.type
!= BT_UNKNOWN
)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts
= gfc_get_default_type (sym
->name
, ns
);
259 if (ts
->type
== BT_UNKNOWN
)
261 if (error_flag
&& !sym
->attr
.untyped
)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym
->name
, &sym
->declared_at
);
265 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
272 sym
->attr
.implicit_type
= 1;
274 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
275 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
277 if (sym
->attr
.is_bind_c
== 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym
->name
, &sym
->declared_at
);
282 sym
->ts
.f90_type
= sym
->ts
.type
;
285 if (sym
->attr
.dummy
!= 0)
287 if (sym
->ns
->proc_name
!= NULL
288 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
289 || sym
->ns
->proc_name
->attr
.function
!= 0)
290 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym
->name
,
297 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
298 &(sym
->ns
->proc_name
->declared_at
));
299 sym
->ts
.f90_type
= sym
->ts
.type
;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace
*ns
)
314 gfc_symbol
*proc
= ns
->proc_name
;
316 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
319 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
321 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
324 if (proc
->result
!= proc
)
326 proc
->ts
= proc
->result
->ts
;
327 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
328 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
329 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
330 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
333 else if (!proc
->result
->attr
.proc_pointer
)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc
->result
->name
, &proc
->result
->declared_at
);
337 proc
->result
->attr
.untyped
= 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
361 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
362 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
363 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
364 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
365 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
366 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
367 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
368 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
369 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
370 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
371 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
372 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
373 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
374 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE",
375 *asynchronous
= "ASYNCHRONOUS", *codimension
= "CODIMENSION",
376 *contiguous
= "CONTIGUOUS";
377 static const char *threadprivate
= "THREADPRIVATE";
383 where
= &gfc_current_locus
;
385 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
389 standard
= GFC_STD_F2003
;
393 /* Check for attributes not allowed in a BLOCK DATA. */
394 if (gfc_current_state () == COMP_BLOCK_DATA
)
398 if (attr
->in_namelist
)
400 if (attr
->allocatable
)
406 if (attr
->access
== ACCESS_PRIVATE
)
408 if (attr
->access
== ACCESS_PUBLIC
)
410 if (attr
->intent
!= INTENT_UNKNOWN
)
416 ("%s attribute not allowed in BLOCK DATA program unit at %L",
422 if (attr
->save
== SAVE_EXPLICIT
)
425 conf (in_common
, save
);
428 switch (attr
->flavor
)
436 a1
= gfc_code2string (flavors
, attr
->flavor
);
441 /* Conflicts between SAVE and PROCEDURE will be checked at
442 resolution stage, see "resolve_fl_procedure". */
451 conf (dummy
, intrinsic
);
452 conf (dummy
, threadprivate
);
453 conf (pointer
, target
);
454 conf (pointer
, intrinsic
);
455 conf (pointer
, elemental
);
456 conf (allocatable
, elemental
);
458 conf (target
, external
);
459 conf (target
, intrinsic
);
461 if (!attr
->if_source
)
462 conf (external
, dimension
); /* See Fortran 95's R504. */
464 conf (external
, intrinsic
);
465 conf (entry
, intrinsic
);
467 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
468 conf (external
, subroutine
);
470 if (attr
->proc_pointer
&& gfc_notify_std (GFC_STD_F2003
,
471 "Fortran 2003: Procedure pointer at %C") == FAILURE
)
474 conf (allocatable
, pointer
);
475 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
476 conf_std (allocatable
, function
, GFC_STD_F2003
);
477 conf_std (allocatable
, result
, GFC_STD_F2003
);
478 conf (elemental
, recursive
);
480 conf (in_common
, dummy
);
481 conf (in_common
, allocatable
);
482 conf (in_common
, codimension
);
483 conf (in_common
, result
);
485 conf (dummy
, result
);
487 conf (in_equivalence
, use_assoc
);
488 conf (in_equivalence
, codimension
);
489 conf (in_equivalence
, dummy
);
490 conf (in_equivalence
, target
);
491 conf (in_equivalence
, pointer
);
492 conf (in_equivalence
, function
);
493 conf (in_equivalence
, result
);
494 conf (in_equivalence
, entry
);
495 conf (in_equivalence
, allocatable
);
496 conf (in_equivalence
, threadprivate
);
498 conf (in_namelist
, pointer
);
499 conf (in_namelist
, allocatable
);
501 conf (entry
, result
);
503 conf (function
, subroutine
);
505 if (!function
&& !subroutine
)
506 conf (is_bind_c
, dummy
);
508 conf (is_bind_c
, cray_pointer
);
509 conf (is_bind_c
, cray_pointee
);
510 conf (is_bind_c
, codimension
);
511 conf (is_bind_c
, allocatable
);
512 conf (is_bind_c
, elemental
);
514 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
515 Parameter conflict caught below. Also, value cannot be specified
516 for a dummy procedure. */
518 /* Cray pointer/pointee conflicts. */
519 conf (cray_pointer
, cray_pointee
);
520 conf (cray_pointer
, dimension
);
521 conf (cray_pointer
, codimension
);
522 conf (cray_pointer
, contiguous
);
523 conf (cray_pointer
, pointer
);
524 conf (cray_pointer
, target
);
525 conf (cray_pointer
, allocatable
);
526 conf (cray_pointer
, external
);
527 conf (cray_pointer
, intrinsic
);
528 conf (cray_pointer
, in_namelist
);
529 conf (cray_pointer
, function
);
530 conf (cray_pointer
, subroutine
);
531 conf (cray_pointer
, entry
);
533 conf (cray_pointee
, allocatable
);
534 conf (cray_pointer
, contiguous
);
535 conf (cray_pointer
, codimension
);
536 conf (cray_pointee
, intent
);
537 conf (cray_pointee
, optional
);
538 conf (cray_pointee
, dummy
);
539 conf (cray_pointee
, target
);
540 conf (cray_pointee
, intrinsic
);
541 conf (cray_pointee
, pointer
);
542 conf (cray_pointee
, entry
);
543 conf (cray_pointee
, in_common
);
544 conf (cray_pointee
, in_equivalence
);
545 conf (cray_pointee
, threadprivate
);
548 conf (data
, function
);
550 conf (data
, allocatable
);
552 conf (value
, pointer
)
553 conf (value
, allocatable
)
554 conf (value
, subroutine
)
555 conf (value
, function
)
556 conf (value
, volatile_
)
557 conf (value
, dimension
)
558 conf (value
, codimension
)
559 conf (value
, external
)
561 conf (codimension
, result
)
564 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
567 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
571 conf (is_protected
, intrinsic
)
572 conf (is_protected
, in_common
)
574 conf (asynchronous
, intrinsic
)
575 conf (asynchronous
, external
)
577 conf (volatile_
, intrinsic
)
578 conf (volatile_
, external
)
580 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
587 conf (procedure
, allocatable
)
588 conf (procedure
, dimension
)
589 conf (procedure
, codimension
)
590 conf (procedure
, intrinsic
)
591 conf (procedure
, target
)
592 conf (procedure
, value
)
593 conf (procedure
, volatile_
)
594 conf (procedure
, asynchronous
)
595 conf (procedure
, entry
)
597 a1
= gfc_code2string (flavors
, attr
->flavor
);
599 if (attr
->in_namelist
600 && attr
->flavor
!= FL_VARIABLE
601 && attr
->flavor
!= FL_PROCEDURE
602 && attr
->flavor
!= FL_UNKNOWN
)
608 switch (attr
->flavor
)
618 conf2 (asynchronous
);
621 conf2 (is_protected
);
631 conf2 (threadprivate
);
633 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
635 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
636 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
643 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
657 /* Conflicts with INTENT, SAVE and RESULT will be checked
658 at resolution stage, see "resolve_fl_procedure". */
660 if (attr
->subroutine
)
666 conf2 (asynchronous
);
671 conf2 (threadprivate
);
674 if (!attr
->proc_pointer
)
679 case PROC_ST_FUNCTION
:
689 conf2 (threadprivate
);
709 conf2 (threadprivate
);
712 if (attr
->intent
!= INTENT_UNKNOWN
)
729 conf2 (is_protected
);
735 conf2 (asynchronous
);
736 conf2 (threadprivate
);
751 gfc_error ("%s attribute conflicts with %s attribute at %L",
754 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
755 a1
, a2
, name
, where
);
762 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
763 "with %s attribute at %L", a1
, a2
,
768 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
769 "with %s attribute in '%s' at %L",
770 a1
, a2
, name
, where
);
779 /* Mark a symbol as referenced. */
782 gfc_set_sym_referenced (gfc_symbol
*sym
)
785 if (sym
->attr
.referenced
)
788 sym
->attr
.referenced
= 1;
790 /* Remember which order dummy variables are accessed in. */
792 sym
->dummy_order
= next_dummy_order
++;
796 /* Common subroutine called by attribute changing subroutines in order
797 to prevent them from changing a symbol that has been
798 use-associated. Returns zero if it is OK to change the symbol,
802 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
805 if (attr
->use_assoc
== 0)
809 where
= &gfc_current_locus
;
812 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
815 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
822 /* Generate an error because of a duplicate attribute. */
825 duplicate_attr (const char *attr
, locus
*where
)
829 where
= &gfc_current_locus
;
831 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
836 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
837 locus
*where ATTRIBUTE_UNUSED
)
839 attr
->ext_attr
|= 1 << ext_attr
;
844 /* Called from decl.c (attr_decl1) to check attributes, when declared
848 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
850 if (check_used (attr
, NULL
, where
))
853 return check_conflict (attr
, NULL
, where
);
858 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
861 if (check_used (attr
, NULL
, where
))
864 if (attr
->allocatable
)
866 duplicate_attr ("ALLOCATABLE", where
);
870 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
871 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
873 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
878 attr
->allocatable
= 1;
879 return check_conflict (attr
, NULL
, where
);
884 gfc_add_codimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
887 if (check_used (attr
, name
, where
))
890 if (attr
->codimension
)
892 duplicate_attr ("CODIMENSION", where
);
896 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
897 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
899 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
900 "at %L", name
, where
);
904 attr
->codimension
= 1;
905 return check_conflict (attr
, name
, where
);
910 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
913 if (check_used (attr
, name
, where
))
918 duplicate_attr ("DIMENSION", where
);
922 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
923 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
925 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
926 "at %L", name
, where
);
931 return check_conflict (attr
, name
, where
);
936 gfc_add_contiguous (symbol_attribute
*attr
, const char *name
, locus
*where
)
939 if (check_used (attr
, name
, where
))
942 attr
->contiguous
= 1;
943 return check_conflict (attr
, name
, where
);
948 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
951 if (check_used (attr
, NULL
, where
))
956 duplicate_attr ("EXTERNAL", where
);
960 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
963 attr
->proc_pointer
= 1;
968 return check_conflict (attr
, NULL
, where
);
973 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
976 if (check_used (attr
, NULL
, where
))
981 duplicate_attr ("INTRINSIC", where
);
987 return check_conflict (attr
, NULL
, where
);
992 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
995 if (check_used (attr
, NULL
, where
))
1000 duplicate_attr ("OPTIONAL", where
);
1005 return check_conflict (attr
, NULL
, where
);
1010 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
1013 if (check_used (attr
, NULL
, where
))
1016 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
1017 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1019 duplicate_attr ("POINTER", where
);
1023 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
1024 || (attr
->if_source
== IFSRC_IFBODY
1025 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
1026 attr
->proc_pointer
= 1;
1030 return check_conflict (attr
, NULL
, where
);
1035 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
1038 if (check_used (attr
, NULL
, where
))
1041 attr
->cray_pointer
= 1;
1042 return check_conflict (attr
, NULL
, where
);
1047 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
1050 if (check_used (attr
, NULL
, where
))
1053 if (attr
->cray_pointee
)
1055 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1056 " statements", where
);
1060 attr
->cray_pointee
= 1;
1061 return check_conflict (attr
, NULL
, where
);
1066 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1068 if (check_used (attr
, name
, where
))
1071 if (attr
->is_protected
)
1073 if (gfc_notify_std (GFC_STD_LEGACY
,
1074 "Duplicate PROTECTED attribute specified at %L",
1080 attr
->is_protected
= 1;
1081 return check_conflict (attr
, name
, where
);
1086 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1089 if (check_used (attr
, name
, where
))
1093 return check_conflict (attr
, name
, where
);
1098 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
1101 if (check_used (attr
, name
, where
))
1104 if (gfc_pure (NULL
))
1107 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1112 if (attr
->save
== SAVE_EXPLICIT
&& !attr
->vtab
)
1114 if (gfc_notify_std (GFC_STD_LEGACY
,
1115 "Duplicate SAVE attribute specified at %L",
1121 attr
->save
= SAVE_EXPLICIT
;
1122 return check_conflict (attr
, name
, where
);
1127 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1130 if (check_used (attr
, name
, where
))
1135 if (gfc_notify_std (GFC_STD_LEGACY
,
1136 "Duplicate VALUE attribute specified at %L",
1143 return check_conflict (attr
, name
, where
);
1148 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1150 /* No check_used needed as 11.2.1 of the F2003 standard allows
1151 that the local identifier made accessible by a use statement can be
1152 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1154 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1155 if (gfc_notify_std (GFC_STD_LEGACY
,
1156 "Duplicate VOLATILE attribute specified at %L", where
)
1160 attr
->volatile_
= 1;
1161 attr
->volatile_ns
= gfc_current_ns
;
1162 return check_conflict (attr
, name
, where
);
1167 gfc_add_asynchronous (symbol_attribute
*attr
, const char *name
, locus
*where
)
1169 /* No check_used needed as 11.2.1 of the F2003 standard allows
1170 that the local identifier made accessible by a use statement can be
1171 given a ASYNCHRONOUS attribute. */
1173 if (attr
->asynchronous
&& attr
->asynchronous_ns
== gfc_current_ns
)
1174 if (gfc_notify_std (GFC_STD_LEGACY
,
1175 "Duplicate ASYNCHRONOUS attribute specified at %L",
1179 attr
->asynchronous
= 1;
1180 attr
->asynchronous_ns
= gfc_current_ns
;
1181 return check_conflict (attr
, name
, where
);
1186 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1189 if (check_used (attr
, name
, where
))
1192 if (attr
->threadprivate
)
1194 duplicate_attr ("THREADPRIVATE", where
);
1198 attr
->threadprivate
= 1;
1199 return check_conflict (attr
, name
, where
);
1204 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1207 if (check_used (attr
, NULL
, where
))
1212 duplicate_attr ("TARGET", where
);
1217 return check_conflict (attr
, NULL
, where
);
1222 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1225 if (check_used (attr
, name
, where
))
1228 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1230 return check_conflict (attr
, name
, where
);
1235 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1238 if (check_used (attr
, name
, where
))
1241 /* Duplicate attribute already checked for. */
1242 attr
->in_common
= 1;
1243 return check_conflict (attr
, name
, where
);
1248 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1251 /* Duplicate attribute already checked for. */
1252 attr
->in_equivalence
= 1;
1253 if (check_conflict (attr
, name
, where
) == FAILURE
)
1256 if (attr
->flavor
== FL_VARIABLE
)
1259 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1264 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1267 if (check_used (attr
, name
, where
))
1271 return check_conflict (attr
, name
, where
);
1276 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1279 attr
->in_namelist
= 1;
1280 return check_conflict (attr
, name
, where
);
1285 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1288 if (check_used (attr
, name
, where
))
1292 return check_conflict (attr
, name
, where
);
1297 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1300 if (check_used (attr
, NULL
, where
))
1303 if (attr
->elemental
)
1305 duplicate_attr ("ELEMENTAL", where
);
1309 attr
->elemental
= 1;
1310 return check_conflict (attr
, NULL
, where
);
1315 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1318 if (check_used (attr
, NULL
, where
))
1323 duplicate_attr ("PURE", where
);
1328 return check_conflict (attr
, NULL
, where
);
1333 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1336 if (check_used (attr
, NULL
, where
))
1339 if (attr
->recursive
)
1341 duplicate_attr ("RECURSIVE", where
);
1345 attr
->recursive
= 1;
1346 return check_conflict (attr
, NULL
, where
);
1351 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1354 if (check_used (attr
, name
, where
))
1359 duplicate_attr ("ENTRY", where
);
1364 return check_conflict (attr
, name
, where
);
1369 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1372 if (attr
->flavor
!= FL_PROCEDURE
1373 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1377 return check_conflict (attr
, name
, where
);
1382 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1385 if (attr
->flavor
!= FL_PROCEDURE
1386 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1389 attr
->subroutine
= 1;
1390 return check_conflict (attr
, name
, where
);
1395 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1398 if (attr
->flavor
!= FL_PROCEDURE
1399 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1403 return check_conflict (attr
, name
, where
);
1408 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1411 if (check_used (attr
, NULL
, where
))
1414 if (attr
->flavor
!= FL_PROCEDURE
1415 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1418 if (attr
->procedure
)
1420 duplicate_attr ("PROCEDURE", where
);
1424 attr
->procedure
= 1;
1426 return check_conflict (attr
, NULL
, where
);
1431 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1435 duplicate_attr ("ABSTRACT", where
);
1444 /* Flavors are special because some flavors are not what Fortran
1445 considers attributes and can be reaffirmed multiple times. */
1448 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1452 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1453 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1454 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1457 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1460 if (attr
->flavor
!= FL_UNKNOWN
)
1463 where
= &gfc_current_locus
;
1466 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1467 gfc_code2string (flavors
, attr
->flavor
), name
,
1468 gfc_code2string (flavors
, f
), where
);
1470 gfc_error ("%s attribute conflicts with %s attribute at %L",
1471 gfc_code2string (flavors
, attr
->flavor
),
1472 gfc_code2string (flavors
, f
), where
);
1479 return check_conflict (attr
, name
, where
);
1484 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1485 const char *name
, locus
*where
)
1488 if (check_used (attr
, name
, where
))
1491 if (attr
->flavor
!= FL_PROCEDURE
1492 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1496 where
= &gfc_current_locus
;
1498 if (attr
->proc
!= PROC_UNKNOWN
)
1500 gfc_error ("%s procedure at %L is already declared as %s procedure",
1501 gfc_code2string (procedures
, t
), where
,
1502 gfc_code2string (procedures
, attr
->proc
));
1509 /* Statement functions are always scalar and functions. */
1510 if (t
== PROC_ST_FUNCTION
1511 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1512 || attr
->dimension
))
1515 return check_conflict (attr
, name
, where
);
1520 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1523 if (check_used (attr
, NULL
, where
))
1526 if (attr
->intent
== INTENT_UNKNOWN
)
1528 attr
->intent
= intent
;
1529 return check_conflict (attr
, NULL
, where
);
1533 where
= &gfc_current_locus
;
1535 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1536 gfc_intent_string (attr
->intent
),
1537 gfc_intent_string (intent
), where
);
1543 /* No checks for use-association in public and private statements. */
1546 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1547 const char *name
, locus
*where
)
1550 if (attr
->access
== ACCESS_UNKNOWN
1551 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1553 attr
->access
= access
;
1554 return check_conflict (attr
, name
, where
);
1558 where
= &gfc_current_locus
;
1559 gfc_error ("ACCESS specification at %L was already specified", where
);
1565 /* Set the is_bind_c field for the given symbol_attribute. */
1568 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1569 int is_proc_lang_bind_spec
)
1572 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1573 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1574 "variables or common blocks", where
);
1575 else if (attr
->is_bind_c
)
1576 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1578 attr
->is_bind_c
= 1;
1581 where
= &gfc_current_locus
;
1583 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1587 return check_conflict (attr
, name
, where
);
1591 /* Set the extension field for the given symbol_attribute. */
1594 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1597 where
= &gfc_current_locus
;
1599 if (attr
->extension
)
1600 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1602 attr
->extension
= 1;
1604 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1613 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1614 gfc_formal_arglist
* formal
, locus
*where
)
1617 if (check_used (&sym
->attr
, sym
->name
, where
))
1621 where
= &gfc_current_locus
;
1623 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1624 && sym
->attr
.if_source
!= IFSRC_DECL
)
1626 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1631 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1633 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1634 "body", sym
->name
, where
);
1638 sym
->formal
= formal
;
1639 sym
->attr
.if_source
= source
;
1645 /* Add a type to a symbol. */
1648 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1654 where
= &gfc_current_locus
;
1657 type
= sym
->result
->ts
.type
;
1659 type
= sym
->ts
.type
;
1661 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1662 type
= sym
->ns
->proc_name
->ts
.type
;
1664 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1666 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1667 where
, gfc_basic_typename (type
));
1671 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1673 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1674 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1678 flavor
= sym
->attr
.flavor
;
1680 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1681 || flavor
== FL_LABEL
1682 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1683 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1685 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1694 /* Clears all attributes. */
1697 gfc_clear_attr (symbol_attribute
*attr
)
1699 memset (attr
, 0, sizeof (symbol_attribute
));
1703 /* Check for missing attributes in the new symbol. Currently does
1704 nothing, but it's not clear that it is unnecessary yet. */
1707 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1708 locus
*where ATTRIBUTE_UNUSED
)
1715 /* Copy an attribute to a symbol attribute, bit by bit. Some
1716 attributes have a lot of side-effects but cannot be present given
1717 where we are called from, so we ignore some bits. */
1720 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1722 int is_proc_lang_bind_spec
;
1724 /* In line with the other attributes, we only add bits but do not remove
1725 them; cf. also PR 41034. */
1726 dest
->ext_attr
|= src
->ext_attr
;
1728 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1731 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1733 if (src
->codimension
&& gfc_add_codimension (dest
, NULL
, where
) == FAILURE
)
1735 if (src
->contiguous
&& gfc_add_contiguous (dest
, NULL
, where
) == FAILURE
)
1737 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1739 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1741 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1743 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1745 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1747 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1749 if (src
->asynchronous
&& gfc_add_asynchronous (dest
, NULL
, where
) == FAILURE
)
1751 if (src
->threadprivate
1752 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1754 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1756 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1758 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1763 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1766 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1769 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1771 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1773 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1776 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1778 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1780 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1782 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1785 if (src
->flavor
!= FL_UNKNOWN
1786 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1789 if (src
->intent
!= INTENT_UNKNOWN
1790 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1793 if (src
->access
!= ACCESS_UNKNOWN
1794 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1797 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1800 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1802 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1805 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1807 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1811 if (src
->is_c_interop
)
1812 dest
->is_c_interop
= 1;
1816 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1818 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1820 if (src
->proc_pointer
)
1821 dest
->proc_pointer
= 1;
1830 /************** Component name management ************/
1832 /* Component names of a derived type form their own little namespaces
1833 that are separate from all other spaces. The space is composed of
1834 a singly linked list of gfc_component structures whose head is
1835 located in the parent symbol. */
1838 /* Add a component name to a symbol. The call fails if the name is
1839 already present. On success, the component pointer is modified to
1840 point to the additional component structure. */
1843 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1844 gfc_component
**component
)
1846 gfc_component
*p
, *tail
;
1850 for (p
= sym
->components
; p
; p
= p
->next
)
1852 if (strcmp (p
->name
, name
) == 0)
1854 gfc_error ("Component '%s' at %C already declared at %L",
1862 if (sym
->attr
.extension
1863 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1865 gfc_error ("Component '%s' at %C already in the parent type "
1866 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1870 /* Allocate a new component. */
1871 p
= gfc_get_component ();
1874 sym
->components
= p
;
1878 p
->name
= gfc_get_string (name
);
1879 p
->loc
= gfc_current_locus
;
1880 p
->ts
.type
= BT_UNKNOWN
;
1887 /* Recursive function to switch derived types of all symbol in a
1891 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1899 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1900 sym
->ts
.u
.derived
= to
;
1902 switch_types (st
->left
, from
, to
);
1903 switch_types (st
->right
, from
, to
);
1907 /* This subroutine is called when a derived type is used in order to
1908 make the final determination about which version to use. The
1909 standard requires that a type be defined before it is 'used', but
1910 such types can appear in IMPLICIT statements before the actual
1911 definition. 'Using' in this context means declaring a variable to
1912 be that type or using the type constructor.
1914 If a type is used and the components haven't been defined, then we
1915 have to have a derived type in a parent unit. We find the node in
1916 the other namespace and point the symtree node in this namespace to
1917 that node. Further reference to this name point to the correct
1918 node. If we can't find the node in a parent namespace, then we have
1921 This subroutine takes a pointer to a symbol node and returns a
1922 pointer to the translated node or NULL for an error. Usually there
1923 is no translation and we return the node we were passed. */
1926 gfc_use_derived (gfc_symbol
*sym
)
1933 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1934 return sym
; /* Already defined. */
1936 if (sym
->ns
->parent
== NULL
)
1939 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1941 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1945 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1948 /* Get rid of symbol sym, translating all references to s. */
1949 for (i
= 0; i
< GFC_LETTERS
; i
++)
1951 t
= &sym
->ns
->default_type
[i
];
1952 if (t
->u
.derived
== sym
)
1956 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1961 /* Unlink from list of modified symbols. */
1962 gfc_commit_symbol (sym
);
1964 switch_types (sym
->ns
->sym_root
, sym
, s
);
1966 /* TODO: Also have to replace sym -> s in other lists like
1967 namelists, common lists and interface lists. */
1968 gfc_free_symbol (sym
);
1973 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1979 /* Given a derived type node and a component name, try to locate the
1980 component structure. Returns the NULL pointer if the component is
1981 not found or the components are private. If noaccess is set, no access
1985 gfc_find_component (gfc_symbol
*sym
, const char *name
,
1986 bool noaccess
, bool silent
)
1993 sym
= gfc_use_derived (sym
);
1998 for (p
= sym
->components
; p
; p
= p
->next
)
1999 if (strcmp (p
->name
, name
) == 0)
2003 && sym
->attr
.extension
2004 && sym
->components
->ts
.type
== BT_DERIVED
)
2006 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
2008 /* Do not overwrite the error. */
2013 if (p
== NULL
&& !silent
)
2014 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2017 else if (sym
->attr
.use_assoc
&& !noaccess
)
2019 bool is_parent_comp
= sym
->attr
.extension
&& (p
== sym
->components
);
2020 if (p
->attr
.access
== ACCESS_PRIVATE
||
2021 (p
->attr
.access
!= ACCESS_PUBLIC
2022 && sym
->component_access
== ACCESS_PRIVATE
2023 && !is_parent_comp
))
2026 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2036 /* Given a symbol, free all of the component structures and everything
2040 free_components (gfc_component
*p
)
2048 gfc_free_array_spec (p
->as
);
2049 gfc_free_expr (p
->initializer
);
2056 /******************** Statement label management ********************/
2058 /* Comparison function for statement labels, used for managing the
2062 compare_st_labels (void *a1
, void *b1
)
2064 int a
= ((gfc_st_label
*) a1
)->value
;
2065 int b
= ((gfc_st_label
*) b1
)->value
;
2071 /* Free a single gfc_st_label structure, making sure the tree is not
2072 messed up. This function is called only when some parse error
2076 gfc_free_st_label (gfc_st_label
*label
)
2082 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2084 if (label
->format
!= NULL
)
2085 gfc_free_expr (label
->format
);
2091 /* Free a whole tree of gfc_st_label structures. */
2094 free_st_labels (gfc_st_label
*label
)
2100 free_st_labels (label
->left
);
2101 free_st_labels (label
->right
);
2103 if (label
->format
!= NULL
)
2104 gfc_free_expr (label
->format
);
2109 /* Given a label number, search for and return a pointer to the label
2110 structure, creating it if it does not exist. */
2113 gfc_get_st_label (int labelno
)
2118 /* Find the namespace of the scoping unit:
2119 If we're in a BLOCK construct, jump to the parent namespace. */
2120 ns
= gfc_current_ns
;
2121 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2124 /* First see if the label is already in this namespace. */
2128 if (lp
->value
== labelno
)
2131 if (lp
->value
< labelno
)
2137 lp
= XCNEW (gfc_st_label
);
2139 lp
->value
= labelno
;
2140 lp
->defined
= ST_LABEL_UNKNOWN
;
2141 lp
->referenced
= ST_LABEL_UNKNOWN
;
2143 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2149 /* Called when a statement with a statement label is about to be
2150 accepted. We add the label to the list of the current namespace,
2151 making sure it hasn't been defined previously and referenced
2155 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2159 labelno
= lp
->value
;
2161 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2162 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2163 &lp
->where
, label_locus
);
2166 lp
->where
= *label_locus
;
2170 case ST_LABEL_FORMAT
:
2171 if (lp
->referenced
== ST_LABEL_TARGET
)
2172 gfc_error ("Label %d at %C already referenced as branch target",
2175 lp
->defined
= ST_LABEL_FORMAT
;
2179 case ST_LABEL_TARGET
:
2180 if (lp
->referenced
== ST_LABEL_FORMAT
)
2181 gfc_error ("Label %d at %C already referenced as a format label",
2184 lp
->defined
= ST_LABEL_TARGET
;
2189 lp
->defined
= ST_LABEL_BAD_TARGET
;
2190 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2196 /* Reference a label. Given a label and its type, see if that
2197 reference is consistent with what is known about that label,
2198 updating the unknown state. Returns FAILURE if something goes
2202 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2204 gfc_sl_type label_type
;
2211 labelno
= lp
->value
;
2213 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2214 label_type
= lp
->defined
;
2217 label_type
= lp
->referenced
;
2218 lp
->where
= gfc_current_locus
;
2221 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2223 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2228 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2229 && type
== ST_LABEL_FORMAT
)
2231 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2236 lp
->referenced
= type
;
2244 /*******A helper function for creating new expressions*************/
2248 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2251 lval
= gfc_get_expr ();
2252 lval
->expr_type
= EXPR_VARIABLE
;
2253 lval
->where
= sym
->declared_at
;
2255 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2257 /* It will always be a full array. */
2258 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2261 lval
->ref
= gfc_get_ref ();
2262 lval
->ref
->type
= REF_ARRAY
;
2263 lval
->ref
->u
.ar
.type
= AR_FULL
;
2264 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2265 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2266 lval
->ref
->u
.ar
.as
= sym
->as
;
2273 /************** Symbol table management subroutines ****************/
2275 /* Basic details: Fortran 95 requires a potentially unlimited number
2276 of distinct namespaces when compiling a program unit. This case
2277 occurs during a compilation of internal subprograms because all of
2278 the internal subprograms must be read before we can start
2279 generating code for the host.
2281 Given the tricky nature of the Fortran grammar, we must be able to
2282 undo changes made to a symbol table if the current interpretation
2283 of a statement is found to be incorrect. Whenever a symbol is
2284 looked up, we make a copy of it and link to it. All of these
2285 symbols are kept in a singly linked list so that we can commit or
2286 undo the changes at a later time.
2288 A symtree may point to a symbol node outside of its namespace. In
2289 this case, that symbol has been used as a host associated variable
2290 at some previous time. */
2292 /* Allocate a new namespace structure. Copies the implicit types from
2293 PARENT if PARENT_TYPES is set. */
2296 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2303 ns
= XCNEW (gfc_namespace
);
2304 ns
->sym_root
= NULL
;
2305 ns
->uop_root
= NULL
;
2306 ns
->tb_sym_root
= NULL
;
2307 ns
->finalizers
= NULL
;
2308 ns
->default_access
= ACCESS_UNKNOWN
;
2309 ns
->parent
= parent
;
2311 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2313 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2314 ns
->tb_op
[in
] = NULL
;
2317 /* Initialize default implicit types. */
2318 for (i
= 'a'; i
<= 'z'; i
++)
2320 ns
->set_flag
[i
- 'a'] = 0;
2321 ts
= &ns
->default_type
[i
- 'a'];
2323 if (parent_types
&& ns
->parent
!= NULL
)
2325 /* Copy parent settings. */
2326 *ts
= ns
->parent
->default_type
[i
- 'a'];
2330 if (gfc_option
.flag_implicit_none
!= 0)
2336 if ('i' <= i
&& i
<= 'n')
2338 ts
->type
= BT_INTEGER
;
2339 ts
->kind
= gfc_default_integer_kind
;
2344 ts
->kind
= gfc_default_real_kind
;
2354 /* Comparison function for symtree nodes. */
2357 compare_symtree (void *_st1
, void *_st2
)
2359 gfc_symtree
*st1
, *st2
;
2361 st1
= (gfc_symtree
*) _st1
;
2362 st2
= (gfc_symtree
*) _st2
;
2364 return strcmp (st1
->name
, st2
->name
);
2368 /* Allocate a new symtree node and associate it with the new symbol. */
2371 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2375 st
= XCNEW (gfc_symtree
);
2376 st
->name
= gfc_get_string (name
);
2378 gfc_insert_bbt (root
, st
, compare_symtree
);
2383 /* Delete a symbol from the tree. Does not free the symbol itself! */
2386 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2388 gfc_symtree st
, *st0
;
2390 st0
= gfc_find_symtree (*root
, name
);
2392 st
.name
= gfc_get_string (name
);
2393 gfc_delete_bbt (root
, &st
, compare_symtree
);
2399 /* Given a root symtree node and a name, try to find the symbol within
2400 the namespace. Returns NULL if the symbol is not found. */
2403 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2409 c
= strcmp (name
, st
->name
);
2413 st
= (c
< 0) ? st
->left
: st
->right
;
2420 /* Return a symtree node with a name that is guaranteed to be unique
2421 within the namespace and corresponds to an illegal fortran name. */
2424 gfc_get_unique_symtree (gfc_namespace
*ns
)
2426 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2427 static int serial
= 0;
2429 sprintf (name
, "@%d", serial
++);
2430 return gfc_new_symtree (&ns
->sym_root
, name
);
2434 /* Given a name find a user operator node, creating it if it doesn't
2435 exist. These are much simpler than symbols because they can't be
2436 ambiguous with one another. */
2439 gfc_get_uop (const char *name
)
2444 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2448 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2450 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2451 uop
->name
= gfc_get_string (name
);
2452 uop
->access
= ACCESS_UNKNOWN
;
2453 uop
->ns
= gfc_current_ns
;
2459 /* Given a name find the user operator node. Returns NULL if it does
2463 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2468 ns
= gfc_current_ns
;
2470 st
= gfc_find_symtree (ns
->uop_root
, name
);
2471 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2475 /* Remove a gfc_symbol structure and everything it points to. */
2478 gfc_free_symbol (gfc_symbol
*sym
)
2484 gfc_free_array_spec (sym
->as
);
2486 free_components (sym
->components
);
2488 gfc_free_expr (sym
->value
);
2490 gfc_free_namelist (sym
->namelist
);
2492 gfc_free_namespace (sym
->formal_ns
);
2494 if (!sym
->attr
.generic_copy
)
2495 gfc_free_interface (sym
->generic
);
2497 gfc_free_formal_arglist (sym
->formal
);
2499 gfc_free_namespace (sym
->f2k_derived
);
2505 /* Allocate and initialize a new symbol node. */
2508 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2512 p
= XCNEW (gfc_symbol
);
2514 gfc_clear_ts (&p
->ts
);
2515 gfc_clear_attr (&p
->attr
);
2518 p
->declared_at
= gfc_current_locus
;
2520 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2521 gfc_internal_error ("new_symbol(): Symbol name too long");
2523 p
->name
= gfc_get_string (name
);
2525 /* Make sure flags for symbol being C bound are clear initially. */
2526 p
->attr
.is_bind_c
= 0;
2527 p
->attr
.is_iso_c
= 0;
2528 /* Make sure the binding label field has a Nul char to start. */
2529 p
->binding_label
[0] = '\0';
2531 /* Clear the ptrs we may need. */
2532 p
->common_block
= NULL
;
2533 p
->f2k_derived
= NULL
;
2540 /* Generate an error if a symbol is ambiguous. */
2543 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2546 if (st
->n
.sym
->module
)
2547 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2548 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2550 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2551 "from current program unit", name
, st
->n
.sym
->name
);
2555 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2556 selector on the stack. If yes, replace it by the corresponding temporary. */
2559 select_type_insert_tmp (gfc_symtree
**st
)
2561 gfc_select_type_stack
*stack
= select_type_stack
;
2562 for (; stack
; stack
= stack
->prev
)
2563 if ((*st
)->n
.sym
== stack
->selector
&& stack
->tmp
)
2568 /* Search for a symtree starting in the current namespace, resorting to
2569 any parent namespaces if requested by a nonzero parent_flag.
2570 Returns nonzero if the name is ambiguous. */
2573 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2574 gfc_symtree
**result
)
2579 ns
= gfc_current_ns
;
2583 st
= gfc_find_symtree (ns
->sym_root
, name
);
2586 select_type_insert_tmp (&st
);
2589 /* Ambiguous generic interfaces are permitted, as long
2590 as the specific interfaces are different. */
2591 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2593 ambiguous_symbol (name
, st
);
2612 /* Same, but returns the symbol instead. */
2615 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2616 gfc_symbol
**result
)
2621 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2626 *result
= st
->n
.sym
;
2632 /* Save symbol with the information necessary to back it out. */
2635 save_symbol_data (gfc_symbol
*sym
)
2638 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2641 sym
->old_symbol
= XCNEW (gfc_symbol
);
2642 *(sym
->old_symbol
) = *sym
;
2644 sym
->tlink
= changed_syms
;
2649 /* Given a name, find a symbol, or create it if it does not exist yet
2650 in the current namespace. If the symbol is found we make sure that
2653 The integer return code indicates
2655 1 The symbol name was ambiguous
2656 2 The name meant to be established was already host associated.
2658 So if the return value is nonzero, then an error was issued. */
2661 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2662 bool allow_subroutine
)
2667 /* This doesn't usually happen during resolution. */
2669 ns
= gfc_current_ns
;
2671 /* Try to find the symbol in ns. */
2672 st
= gfc_find_symtree (ns
->sym_root
, name
);
2676 /* If not there, create a new symbol. */
2677 p
= gfc_new_symbol (name
, ns
);
2679 /* Add to the list of tentative symbols. */
2680 p
->old_symbol
= NULL
;
2681 p
->tlink
= changed_syms
;
2686 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2693 /* Make sure the existing symbol is OK. Ambiguous
2694 generic interfaces are permitted, as long as the
2695 specific interfaces are different. */
2696 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2698 ambiguous_symbol (name
, st
);
2703 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2704 && !(allow_subroutine
&& p
->attr
.subroutine
)
2705 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2706 && (ns
->has_import_set
|| p
->attr
.imported
)))
2708 /* Symbol is from another namespace. */
2709 gfc_error ("Symbol '%s' at %C has already been host associated",
2716 /* Copy in case this symbol is changed. */
2717 save_symbol_data (p
);
2726 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2731 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2736 *result
= st
->n
.sym
;
2743 /* Subroutine that searches for a symbol, creating it if it doesn't
2744 exist, but tries to host-associate the symbol if possible. */
2747 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2752 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2756 save_symbol_data (st
->n
.sym
);
2761 if (gfc_current_ns
->parent
!= NULL
)
2763 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2774 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2779 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2784 i
= gfc_get_ha_sym_tree (name
, &st
);
2787 *result
= st
->n
.sym
;
2794 /* Return true if both symbols could refer to the same data object. Does
2795 not take account of aliasing due to equivalence statements. */
2798 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2800 /* Aliasing isn't possible if the symbols have different base types. */
2801 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2804 /* Pointers can point to other pointers, target objects and allocatable
2805 objects. Two allocatable objects cannot share the same storage. */
2806 if (lsym
->attr
.pointer
2807 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2809 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2811 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2814 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
2815 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
2817 if (lsym
->attr
.target
&& rsym
->attr
.target
2818 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
2819 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
2820 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
2821 && (!rsym
->attr
.dimension
2822 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
2829 /* Undoes all the changes made to symbols in the current statement.
2830 This subroutine is made simpler due to the fact that attributes are
2831 never removed once added. */
2834 gfc_undo_symbols (void)
2836 gfc_symbol
*p
, *q
, *old
;
2837 tentative_tbp
*tbp
, *tbq
;
2839 for (p
= changed_syms
; p
; p
= q
)
2845 /* Symbol was new. */
2846 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
2848 /* If the symbol was added to any common block, it
2849 needs to be removed to stop the resolver looking
2850 for a (possibly) dead symbol. */
2852 if (p
->common_block
->head
== p
)
2853 p
->common_block
->head
= p
->common_next
;
2856 gfc_symbol
*cparent
, *csym
;
2858 cparent
= p
->common_block
->head
;
2859 csym
= cparent
->common_next
;
2864 csym
= csym
->common_next
;
2867 gcc_assert(cparent
->common_next
== p
);
2869 cparent
->common_next
= csym
->common_next
;
2873 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2877 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2879 gfc_free_symbol (p
);
2883 /* Restore previous state of symbol. Just copy simple stuff. */
2885 old
= p
->old_symbol
;
2887 p
->ts
.type
= old
->ts
.type
;
2888 p
->ts
.kind
= old
->ts
.kind
;
2890 p
->attr
= old
->attr
;
2892 if (p
->value
!= old
->value
)
2894 gfc_free_expr (old
->value
);
2898 if (p
->as
!= old
->as
)
2901 gfc_free_array_spec (p
->as
);
2905 p
->generic
= old
->generic
;
2906 p
->component_access
= old
->component_access
;
2908 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2910 gfc_free_namelist (p
->namelist
);
2915 if (p
->namelist_tail
!= old
->namelist_tail
)
2917 gfc_free_namelist (old
->namelist_tail
);
2918 old
->namelist_tail
->next
= NULL
;
2922 p
->namelist_tail
= old
->namelist_tail
;
2924 if (p
->formal
!= old
->formal
)
2926 gfc_free_formal_arglist (p
->formal
);
2927 p
->formal
= old
->formal
;
2930 gfc_free (p
->old_symbol
);
2931 p
->old_symbol
= NULL
;
2935 changed_syms
= NULL
;
2937 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2940 /* Procedure is already marked `error' by default. */
2943 tentative_tbp_list
= NULL
;
2947 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2948 components of old_symbol that might need deallocation are the "allocatables"
2949 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2950 namelist_tail. In case these differ between old_symbol and sym, it's just
2951 because sym->namelist has gotten a few more items. */
2954 free_old_symbol (gfc_symbol
*sym
)
2957 if (sym
->old_symbol
== NULL
)
2960 if (sym
->old_symbol
->as
!= sym
->as
)
2961 gfc_free_array_spec (sym
->old_symbol
->as
);
2963 if (sym
->old_symbol
->value
!= sym
->value
)
2964 gfc_free_expr (sym
->old_symbol
->value
);
2966 if (sym
->old_symbol
->formal
!= sym
->formal
)
2967 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2969 gfc_free (sym
->old_symbol
);
2970 sym
->old_symbol
= NULL
;
2974 /* Makes the changes made in the current statement permanent-- gets
2975 rid of undo information. */
2978 gfc_commit_symbols (void)
2981 tentative_tbp
*tbp
, *tbq
;
2983 for (p
= changed_syms
; p
; p
= q
)
2989 free_old_symbol (p
);
2991 changed_syms
= NULL
;
2993 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2996 tbp
->proc
->error
= 0;
2999 tentative_tbp_list
= NULL
;
3003 /* Makes the changes made in one symbol permanent -- gets rid of undo
3007 gfc_commit_symbol (gfc_symbol
*sym
)
3011 if (changed_syms
== sym
)
3012 changed_syms
= sym
->tlink
;
3015 for (p
= changed_syms
; p
; p
= p
->tlink
)
3016 if (p
->tlink
== sym
)
3018 p
->tlink
= sym
->tlink
;
3027 free_old_symbol (sym
);
3031 /* Recursively free trees containing type-bound procedures. */
3034 free_tb_tree (gfc_symtree
*t
)
3039 free_tb_tree (t
->left
);
3040 free_tb_tree (t
->right
);
3042 /* TODO: Free type-bound procedure structs themselves; probably needs some
3043 sort of ref-counting mechanism. */
3049 /* Recursive function that deletes an entire tree and all the common
3050 head structures it points to. */
3053 free_common_tree (gfc_symtree
* common_tree
)
3055 if (common_tree
== NULL
)
3058 free_common_tree (common_tree
->left
);
3059 free_common_tree (common_tree
->right
);
3061 gfc_free (common_tree
);
3065 /* Recursive function that deletes an entire tree and all the user
3066 operator nodes that it contains. */
3069 free_uop_tree (gfc_symtree
*uop_tree
)
3071 if (uop_tree
== NULL
)
3074 free_uop_tree (uop_tree
->left
);
3075 free_uop_tree (uop_tree
->right
);
3077 gfc_free_interface (uop_tree
->n
.uop
->op
);
3078 gfc_free (uop_tree
->n
.uop
);
3079 gfc_free (uop_tree
);
3083 /* Recursive function that deletes an entire tree and all the symbols
3084 that it contains. */
3087 free_sym_tree (gfc_symtree
*sym_tree
)
3092 if (sym_tree
== NULL
)
3095 free_sym_tree (sym_tree
->left
);
3096 free_sym_tree (sym_tree
->right
);
3098 sym
= sym_tree
->n
.sym
;
3102 gfc_internal_error ("free_sym_tree(): Negative refs");
3104 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
3106 /* As formal_ns contains a reference to sym, delete formal_ns just
3107 before the deletion of sym. */
3108 ns
= sym
->formal_ns
;
3109 sym
->formal_ns
= NULL
;
3110 gfc_free_namespace (ns
);
3112 else if (sym
->refs
== 0)
3114 /* Go ahead and delete the symbol. */
3115 gfc_free_symbol (sym
);
3118 gfc_free (sym_tree
);
3122 /* Free the derived type list. */
3125 gfc_free_dt_list (void)
3127 gfc_dt_list
*dt
, *n
;
3129 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3135 gfc_derived_types
= NULL
;
3139 /* Free the gfc_equiv_info's. */
3142 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3146 gfc_free_equiv_infos (s
->next
);
3151 /* Free the gfc_equiv_lists. */
3154 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3158 gfc_free_equiv_lists (l
->next
);
3159 gfc_free_equiv_infos (l
->equiv
);
3164 /* Free a finalizer procedure list. */
3167 gfc_free_finalizer (gfc_finalizer
* el
)
3173 --el
->proc_sym
->refs
;
3174 if (!el
->proc_sym
->refs
)
3175 gfc_free_symbol (el
->proc_sym
);
3183 gfc_free_finalizer_list (gfc_finalizer
* list
)
3187 gfc_finalizer
* current
= list
;
3189 gfc_free_finalizer (current
);
3194 /* Create a new gfc_charlen structure and add it to a namespace.
3195 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3198 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3201 cl
= gfc_get_charlen ();
3203 /* Put into namespace. */
3204 cl
->next
= ns
->cl_list
;
3210 cl
->length
= gfc_copy_expr (old_cl
->length
);
3211 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3212 cl
->backend_decl
= old_cl
->backend_decl
;
3213 cl
->passed_length
= old_cl
->passed_length
;
3214 cl
->resolved
= old_cl
->resolved
;
3221 /* Free the charlen list from cl to end (end is not freed).
3222 Free the whole list if end is NULL. */
3224 void gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3228 for (; cl
!= end
; cl
= cl2
)
3233 gfc_free_expr (cl
->length
);
3239 /* Free a namespace structure and everything below it. Interface
3240 lists associated with intrinsic operators are not freed. These are
3241 taken care of when a specific name is freed. */
3244 gfc_free_namespace (gfc_namespace
*ns
)
3246 gfc_namespace
*p
, *q
;
3255 gcc_assert (ns
->refs
== 0);
3257 gfc_free_statements (ns
->code
);
3259 free_sym_tree (ns
->sym_root
);
3260 free_uop_tree (ns
->uop_root
);
3261 free_common_tree (ns
->common_root
);
3262 free_tb_tree (ns
->tb_sym_root
);
3263 free_tb_tree (ns
->tb_uop_root
);
3264 gfc_free_finalizer_list (ns
->finalizers
);
3265 gfc_free_charlen (ns
->cl_list
, NULL
);
3266 free_st_labels (ns
->st_labels
);
3268 gfc_free_equiv (ns
->equiv
);
3269 gfc_free_equiv_lists (ns
->equiv_lists
);
3270 gfc_free_use_stmts (ns
->use_stmts
);
3272 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3273 gfc_free_interface (ns
->op
[i
]);
3275 gfc_free_data (ns
->data
);
3279 /* Recursively free any contained namespaces. */
3284 gfc_free_namespace (q
);
3290 gfc_symbol_init_2 (void)
3293 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3298 gfc_symbol_done_2 (void)
3301 gfc_free_namespace (gfc_current_ns
);
3302 gfc_current_ns
= NULL
;
3303 gfc_free_dt_list ();
3307 /* Clear mark bits from symbol nodes associated with a symtree node. */
3310 clear_sym_mark (gfc_symtree
*st
)
3313 st
->n
.sym
->mark
= 0;
3317 /* Recursively traverse the symtree nodes. */
3320 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
3325 gfc_traverse_symtree (st
->left
, func
);
3327 gfc_traverse_symtree (st
->right
, func
);
3331 /* Recursive namespace traversal function. */
3334 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
3340 traverse_ns (st
->left
, func
);
3342 if (st
->n
.sym
->mark
== 0)
3343 (*func
) (st
->n
.sym
);
3344 st
->n
.sym
->mark
= 1;
3346 traverse_ns (st
->right
, func
);
3350 /* Call a given function for all symbols in the namespace. We take
3351 care that each gfc_symbol node is called exactly once. */
3354 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3357 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3359 traverse_ns (ns
->sym_root
, func
);
3363 /* Return TRUE when name is the name of an intrinsic type. */
3366 gfc_is_intrinsic_typename (const char *name
)
3368 if (strcmp (name
, "integer") == 0
3369 || strcmp (name
, "real") == 0
3370 || strcmp (name
, "character") == 0
3371 || strcmp (name
, "logical") == 0
3372 || strcmp (name
, "complex") == 0
3373 || strcmp (name
, "doubleprecision") == 0
3374 || strcmp (name
, "doublecomplex") == 0)
3381 /* Return TRUE if the symbol is an automatic variable. */
3384 gfc_is_var_automatic (gfc_symbol
*sym
)
3386 /* Pointer and allocatable variables are never automatic. */
3387 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3389 /* Check for arrays with non-constant size. */
3390 if (sym
->attr
.dimension
&& sym
->as
3391 && !gfc_is_compile_time_shape (sym
->as
))
3393 /* Check for non-constant length character variables. */
3394 if (sym
->ts
.type
== BT_CHARACTER
3396 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3401 /* Given a symbol, mark it as SAVEd if it is allowed. */
3404 save_symbol (gfc_symbol
*sym
)
3407 if (sym
->attr
.use_assoc
)
3410 if (sym
->attr
.in_common
3413 || sym
->attr
.flavor
!= FL_VARIABLE
)
3415 /* Automatic objects are not saved. */
3416 if (gfc_is_var_automatic (sym
))
3418 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3422 /* Mark those symbols which can be SAVEd as such. */
3425 gfc_save_all (gfc_namespace
*ns
)
3427 gfc_traverse_ns (ns
, save_symbol
);
3432 /* Make sure that no changes to symbols are pending. */
3435 gfc_symbol_state(void) {
3437 if (changed_syms
!= NULL
)
3438 gfc_internal_error("Symbol changes still pending!");
3443 /************** Global symbol handling ************/
3446 /* Search a tree for the global symbol. */
3449 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3458 c
= strcmp (name
, symbol
->name
);
3462 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3469 /* Compare two global symbols. Used for managing the BB tree. */
3472 gsym_compare (void *_s1
, void *_s2
)
3474 gfc_gsymbol
*s1
, *s2
;
3476 s1
= (gfc_gsymbol
*) _s1
;
3477 s2
= (gfc_gsymbol
*) _s2
;
3478 return strcmp (s1
->name
, s2
->name
);
3482 /* Get a global symbol, creating it if it doesn't exist. */
3485 gfc_get_gsymbol (const char *name
)
3489 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3493 s
= XCNEW (gfc_gsymbol
);
3494 s
->type
= GSYM_UNKNOWN
;
3495 s
->name
= gfc_get_string (name
);
3497 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3504 get_iso_c_binding_dt (int sym_id
)
3506 gfc_dt_list
*dt_list
;
3508 dt_list
= gfc_derived_types
;
3510 /* Loop through the derived types in the name list, searching for
3511 the desired symbol from iso_c_binding. Search the parent namespaces
3512 if necessary and requested to (parent_flag). */
3513 while (dt_list
!= NULL
)
3515 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3516 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3517 return dt_list
->derived
;
3519 dt_list
= dt_list
->next
;
3526 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3527 with C. This is necessary for any derived type that is BIND(C) and for
3528 derived types that are parameters to functions that are BIND(C). All
3529 fields of the derived type are required to be interoperable, and are tested
3530 for such. If an error occurs, the errors are reported here, allowing for
3531 multiple errors to be handled for a single derived type. */
3534 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3536 gfc_component
*curr_comp
= NULL
;
3537 gfc_try is_c_interop
= FAILURE
;
3538 gfc_try retval
= SUCCESS
;
3540 if (derived_sym
== NULL
)
3541 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3542 "unexpectedly NULL");
3544 /* If we've already looked at this derived symbol, do not look at it again
3545 so we don't repeat warnings/errors. */
3546 if (derived_sym
->ts
.is_c_interop
)
3549 /* The derived type must have the BIND attribute to be interoperable
3550 J3/04-007, Section 15.2.3. */
3551 if (derived_sym
->attr
.is_bind_c
!= 1)
3553 derived_sym
->ts
.is_c_interop
= 0;
3554 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3555 "attribute to be C interoperable", derived_sym
->name
,
3556 &(derived_sym
->declared_at
));
3560 curr_comp
= derived_sym
->components
;
3562 /* TODO: is this really an error? */
3563 if (curr_comp
== NULL
)
3565 gfc_error ("Derived type '%s' at %L is empty",
3566 derived_sym
->name
, &(derived_sym
->declared_at
));
3570 /* Initialize the derived type as being C interoperable.
3571 If we find an error in the components, this will be set false. */
3572 derived_sym
->ts
.is_c_interop
= 1;
3574 /* Loop through the list of components to verify that the kind of
3575 each is a C interoperable type. */
3578 /* The components cannot be pointers (fortran sense).
3579 J3/04-007, Section 15.2.3, C1505. */
3580 if (curr_comp
->attr
.pointer
!= 0)
3582 gfc_error ("Component '%s' at %L cannot have the "
3583 "POINTER attribute because it is a member "
3584 "of the BIND(C) derived type '%s' at %L",
3585 curr_comp
->name
, &(curr_comp
->loc
),
3586 derived_sym
->name
, &(derived_sym
->declared_at
));
3590 if (curr_comp
->attr
.proc_pointer
!= 0)
3592 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3593 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3594 &curr_comp
->loc
, derived_sym
->name
,
3595 &derived_sym
->declared_at
);
3599 /* The components cannot be allocatable.
3600 J3/04-007, Section 15.2.3, C1505. */
3601 if (curr_comp
->attr
.allocatable
!= 0)
3603 gfc_error ("Component '%s' at %L cannot have the "
3604 "ALLOCATABLE attribute because it is a member "
3605 "of the BIND(C) derived type '%s' at %L",
3606 curr_comp
->name
, &(curr_comp
->loc
),
3607 derived_sym
->name
, &(derived_sym
->declared_at
));
3611 /* BIND(C) derived types must have interoperable components. */
3612 if (curr_comp
->ts
.type
== BT_DERIVED
3613 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3614 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3616 /* This should be allowed; the draft says a derived-type can not
3617 have type parameters if it is has the BIND attribute. Type
3618 parameters seem to be for making parameterized derived types.
3619 There's no need to verify the type if it is c_ptr/c_funptr. */
3620 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3624 /* Grab the typespec for the given component and test the kind. */
3625 is_c_interop
= verify_c_interop (&(curr_comp
->ts
));
3627 if (is_c_interop
!= SUCCESS
)
3629 /* Report warning and continue since not fatal. The
3630 draft does specify a constraint that requires all fields
3631 to interoperate, but if the user says real(4), etc., it
3632 may interoperate with *something* in C, but the compiler
3633 most likely won't know exactly what. Further, it may not
3634 interoperate with the same data type(s) in C if the user
3635 recompiles with different flags (e.g., -m32 and -m64 on
3636 x86_64 and using integer(4) to claim interop with a
3638 if (derived_sym
->attr
.is_bind_c
== 1)
3639 /* If the derived type is bind(c), all fields must be
3641 gfc_warning ("Component '%s' in derived type '%s' at %L "
3642 "may not be C interoperable, even though "
3643 "derived type '%s' is BIND(C)",
3644 curr_comp
->name
, derived_sym
->name
,
3645 &(curr_comp
->loc
), derived_sym
->name
);
3647 /* If derived type is param to bind(c) routine, or to one
3648 of the iso_c_binding procs, it must be interoperable, so
3649 all fields must interop too. */
3650 gfc_warning ("Component '%s' in derived type '%s' at %L "
3651 "may not be C interoperable",
3652 curr_comp
->name
, derived_sym
->name
,
3657 curr_comp
= curr_comp
->next
;
3658 } while (curr_comp
!= NULL
);
3661 /* Make sure we don't have conflicts with the attributes. */
3662 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3664 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3665 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3666 &(derived_sym
->declared_at
));
3670 if (derived_sym
->attr
.sequence
!= 0)
3672 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3673 "attribute because it is BIND(C)", derived_sym
->name
,
3674 &(derived_sym
->declared_at
));
3678 /* Mark the derived type as not being C interoperable if we found an
3679 error. If there were only warnings, proceed with the assumption
3680 it's interoperable. */
3681 if (retval
== FAILURE
)
3682 derived_sym
->ts
.is_c_interop
= 0;
3688 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3691 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3692 const char *module_name
)
3694 gfc_symtree
*tmp_symtree
;
3695 gfc_symbol
*tmp_sym
;
3698 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3700 if (tmp_symtree
!= NULL
)
3701 tmp_sym
= tmp_symtree
->n
.sym
;
3705 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3706 "create symbol for %s", ptr_name
);
3709 /* Set up the symbol's important fields. Save attr required so we can
3710 initialize the ptr to NULL. */
3711 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3712 tmp_sym
->ts
.is_c_interop
= 1;
3713 tmp_sym
->attr
.is_c_interop
= 1;
3714 tmp_sym
->ts
.is_iso_c
= 1;
3715 tmp_sym
->ts
.type
= BT_DERIVED
;
3717 /* The c_ptr and c_funptr derived types will provide the
3718 definition for c_null_ptr and c_null_funptr, respectively. */
3719 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3720 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3722 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3723 if (tmp_sym
->ts
.u
.derived
== NULL
)
3725 /* This can occur if the user forgot to declare c_ptr or
3726 c_funptr and they're trying to use one of the procedures
3727 that has arg(s) of the missing type. In this case, a
3728 regular version of the thing should have been put in the
3730 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3731 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3732 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3733 ? "_gfortran_iso_c_binding_c_ptr"
3734 : "_gfortran_iso_c_binding_c_funptr"));
3736 tmp_sym
->ts
.u
.derived
=
3737 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3738 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3741 /* Module name is some mangled version of iso_c_binding. */
3742 tmp_sym
->module
= gfc_get_string (module_name
);
3744 /* Say it's from the iso_c_binding module. */
3745 tmp_sym
->attr
.is_iso_c
= 1;
3747 tmp_sym
->attr
.use_assoc
= 1;
3748 tmp_sym
->attr
.is_bind_c
= 1;
3749 /* Set the binding_label. */
3750 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3752 /* Set the c_address field of c_null_ptr and c_null_funptr to
3753 the value of NULL. */
3754 tmp_sym
->value
= gfc_get_expr ();
3755 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3756 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3757 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
3758 gfc_constructor_append_expr (&tmp_sym
->value
->value
.constructor
, NULL
, NULL
);
3759 c
= gfc_constructor_first (tmp_sym
->value
->value
.constructor
);
3760 c
->expr
= gfc_get_expr ();
3761 c
->expr
->expr_type
= EXPR_NULL
;
3762 c
->expr
->ts
.is_iso_c
= 1;
3763 /* Must declare c_null_ptr and c_null_funptr as having the
3764 PARAMETER attribute so they can be used in init expressions. */
3765 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3771 /* Add a formal argument, gfc_formal_arglist, to the
3772 end of the given list of arguments. Set the reference to the
3773 provided symbol, param_sym, in the argument. */
3776 add_formal_arg (gfc_formal_arglist
**head
,
3777 gfc_formal_arglist
**tail
,
3778 gfc_formal_arglist
*formal_arg
,
3779 gfc_symbol
*param_sym
)
3781 /* Put in list, either as first arg or at the tail (curr arg). */
3783 *head
= *tail
= formal_arg
;
3786 (*tail
)->next
= formal_arg
;
3787 (*tail
) = formal_arg
;
3790 (*tail
)->sym
= param_sym
;
3791 (*tail
)->next
= NULL
;
3797 /* Generates a symbol representing the CPTR argument to an
3798 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3799 CPTR and add it to the provided argument list. */
3802 gen_cptr_param (gfc_formal_arglist
**head
,
3803 gfc_formal_arglist
**tail
,
3804 const char *module_name
,
3805 gfc_namespace
*ns
, const char *c_ptr_name
,
3808 gfc_symbol
*param_sym
= NULL
;
3809 gfc_symbol
*c_ptr_sym
= NULL
;
3810 gfc_symtree
*param_symtree
= NULL
;
3811 gfc_formal_arglist
*formal_arg
= NULL
;
3812 const char *c_ptr_in
;
3813 const char *c_ptr_type
= NULL
;
3815 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3816 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3818 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3820 if(c_ptr_name
== NULL
)
3821 c_ptr_in
= "gfc_cptr__";
3823 c_ptr_in
= c_ptr_name
;
3824 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
, false);
3825 if (param_symtree
!= NULL
)
3826 param_sym
= param_symtree
->n
.sym
;
3828 gfc_internal_error ("gen_cptr_param(): Unable to "
3829 "create symbol for %s", c_ptr_in
);
3831 /* Set up the appropriate fields for the new c_ptr param sym. */
3833 param_sym
->attr
.flavor
= FL_DERIVED
;
3834 param_sym
->ts
.type
= BT_DERIVED
;
3835 param_sym
->attr
.intent
= INTENT_IN
;
3836 param_sym
->attr
.dummy
= 1;
3838 /* This will pass the ptr to the iso_c routines as a (void *). */
3839 param_sym
->attr
.value
= 1;
3840 param_sym
->attr
.use_assoc
= 1;
3842 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3844 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3845 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3847 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3848 if (c_ptr_sym
== NULL
)
3850 /* This can happen if the user did not define c_ptr but they are
3851 trying to use one of the iso_c_binding functions that need it. */
3852 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3853 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3854 (const char *)c_ptr_type
);
3856 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3857 (const char *)c_ptr_type
);
3859 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3862 param_sym
->ts
.u
.derived
= c_ptr_sym
;
3863 param_sym
->module
= gfc_get_string (module_name
);
3865 /* Make new formal arg. */
3866 formal_arg
= gfc_get_formal_arglist ();
3867 /* Add arg to list of formal args (the CPTR arg). */
3868 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3872 /* Generates a symbol representing the FPTR argument to an
3873 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3874 FPTR and add it to the provided argument list. */
3877 gen_fptr_param (gfc_formal_arglist
**head
,
3878 gfc_formal_arglist
**tail
,
3879 const char *module_name
,
3880 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3882 gfc_symbol
*param_sym
= NULL
;
3883 gfc_symtree
*param_symtree
= NULL
;
3884 gfc_formal_arglist
*formal_arg
= NULL
;
3885 const char *f_ptr_out
= "gfc_fptr__";
3887 if (f_ptr_name
!= NULL
)
3888 f_ptr_out
= f_ptr_name
;
3890 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
, false);
3891 if (param_symtree
!= NULL
)
3892 param_sym
= param_symtree
->n
.sym
;
3894 gfc_internal_error ("generateFPtrParam(): Unable to "
3895 "create symbol for %s", f_ptr_out
);
3897 /* Set up the necessary fields for the fptr output param sym. */
3900 param_sym
->attr
.proc_pointer
= 1;
3902 param_sym
->attr
.pointer
= 1;
3903 param_sym
->attr
.dummy
= 1;
3904 param_sym
->attr
.use_assoc
= 1;
3906 /* ISO C Binding type to allow any pointer type as actual param. */
3907 param_sym
->ts
.type
= BT_VOID
;
3908 param_sym
->module
= gfc_get_string (module_name
);
3911 formal_arg
= gfc_get_formal_arglist ();
3912 /* Add arg to list of formal args. */
3913 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3917 /* Generates a symbol representing the optional SHAPE argument for the
3918 iso_c_binding c_f_pointer() procedure. Also, create a
3919 gfc_formal_arglist for the SHAPE and add it to the provided
3923 gen_shape_param (gfc_formal_arglist
**head
,
3924 gfc_formal_arglist
**tail
,
3925 const char *module_name
,
3926 gfc_namespace
*ns
, const char *shape_param_name
)
3928 gfc_symbol
*param_sym
= NULL
;
3929 gfc_symtree
*param_symtree
= NULL
;
3930 gfc_formal_arglist
*formal_arg
= NULL
;
3931 const char *shape_param
= "gfc_shape_array__";
3934 if (shape_param_name
!= NULL
)
3935 shape_param
= shape_param_name
;
3937 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
, false);
3938 if (param_symtree
!= NULL
)
3939 param_sym
= param_symtree
->n
.sym
;
3941 gfc_internal_error ("generateShapeParam(): Unable to "
3942 "create symbol for %s", shape_param
);
3944 /* Set up the necessary fields for the shape input param sym. */
3946 param_sym
->attr
.dummy
= 1;
3947 param_sym
->attr
.use_assoc
= 1;
3949 /* Integer array, rank 1, describing the shape of the object. Make it's
3950 type BT_VOID initially so we can accept any type/kind combination of
3951 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3952 of BT_INTEGER type. */
3953 param_sym
->ts
.type
= BT_VOID
;
3955 /* Initialize the kind to default integer. However, it will be overridden
3956 during resolution to match the kind of the SHAPE parameter given as
3957 the actual argument (to allow for any valid integer kind). */
3958 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3959 param_sym
->as
= gfc_get_array_spec ();
3961 /* Clear out the dimension info for the array. */
3962 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3964 param_sym
->as
->lower
[i
] = NULL
;
3965 param_sym
->as
->upper
[i
] = NULL
;
3967 param_sym
->as
->rank
= 1;
3968 param_sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
3971 /* The extent is unknown until we get it. The length give us
3972 the rank the incoming pointer. */
3973 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3975 /* The arg is also optional; it is required iff the second arg
3976 (fptr) is to an array, otherwise, it's ignored. */
3977 param_sym
->attr
.optional
= 1;
3978 param_sym
->attr
.intent
= INTENT_IN
;
3979 param_sym
->attr
.dimension
= 1;
3980 param_sym
->module
= gfc_get_string (module_name
);
3983 formal_arg
= gfc_get_formal_arglist ();
3984 /* Add arg to list of formal args. */
3985 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3989 /* Add a procedure interface to the given symbol (i.e., store a
3990 reference to the list of formal arguments). */
3993 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3994 gfc_formal_arglist
*formal
)
3997 sym
->formal
= formal
;
3998 sym
->attr
.if_source
= source
;
4002 /* Copy the formal args from an existing symbol, src, into a new
4003 symbol, dest. New formal args are created, and the description of
4004 each arg is set according to the existing ones. This function is
4005 used when creating procedure declaration variables from a procedure
4006 declaration statement (see match_proc_decl()) to create the formal
4007 args based on the args of a given named interface. */
4010 gfc_copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
4012 gfc_formal_arglist
*head
= NULL
;
4013 gfc_formal_arglist
*tail
= NULL
;
4014 gfc_formal_arglist
*formal_arg
= NULL
;
4015 gfc_formal_arglist
*curr_arg
= NULL
;
4016 gfc_formal_arglist
*formal_prev
= NULL
;
4017 /* Save current namespace so we can change it for formal args. */
4018 gfc_namespace
*parent_ns
= gfc_current_ns
;
4020 /* Create a new namespace, which will be the formal ns (namespace
4021 of the formal args). */
4022 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4023 gfc_current_ns
->proc_name
= dest
;
4025 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4027 formal_arg
= gfc_get_formal_arglist ();
4028 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4030 /* May need to copy more info for the symbol. */
4031 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4032 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4033 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4034 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4036 /* If this isn't the first arg, set up the next ptr. For the
4037 last arg built, the formal_arg->next will never get set to
4038 anything other than NULL. */
4039 if (formal_prev
!= NULL
)
4040 formal_prev
->next
= formal_arg
;
4042 formal_arg
->next
= NULL
;
4044 formal_prev
= formal_arg
;
4046 /* Add arg to list of formal args. */
4047 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4050 /* Add the interface to the symbol. */
4051 add_proc_interface (dest
, IFSRC_DECL
, head
);
4053 /* Store the formal namespace information. */
4054 if (dest
->formal
!= NULL
)
4055 /* The current ns should be that for the dest proc. */
4056 dest
->formal_ns
= gfc_current_ns
;
4057 /* Restore the current namespace to what it was on entry. */
4058 gfc_current_ns
= parent_ns
;
4063 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
4065 gfc_formal_arglist
*head
= NULL
;
4066 gfc_formal_arglist
*tail
= NULL
;
4067 gfc_formal_arglist
*formal_arg
= NULL
;
4068 gfc_intrinsic_arg
*curr_arg
= NULL
;
4069 gfc_formal_arglist
*formal_prev
= NULL
;
4070 /* Save current namespace so we can change it for formal args. */
4071 gfc_namespace
*parent_ns
= gfc_current_ns
;
4073 /* Create a new namespace, which will be the formal ns (namespace
4074 of the formal args). */
4075 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4076 gfc_current_ns
->proc_name
= dest
;
4078 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4080 formal_arg
= gfc_get_formal_arglist ();
4081 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4083 /* May need to copy more info for the symbol. */
4084 formal_arg
->sym
->ts
= curr_arg
->ts
;
4085 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
4086 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
4087 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
4088 formal_arg
->sym
->attr
.dummy
= 1;
4090 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
4091 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4093 /* If this isn't the first arg, set up the next ptr. For the
4094 last arg built, the formal_arg->next will never get set to
4095 anything other than NULL. */
4096 if (formal_prev
!= NULL
)
4097 formal_prev
->next
= formal_arg
;
4099 formal_arg
->next
= NULL
;
4101 formal_prev
= formal_arg
;
4103 /* Add arg to list of formal args. */
4104 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4107 /* Add the interface to the symbol. */
4108 add_proc_interface (dest
, IFSRC_DECL
, head
);
4110 /* Store the formal namespace information. */
4111 if (dest
->formal
!= NULL
)
4112 /* The current ns should be that for the dest proc. */
4113 dest
->formal_ns
= gfc_current_ns
;
4114 /* Restore the current namespace to what it was on entry. */
4115 gfc_current_ns
= parent_ns
;
4120 gfc_copy_formal_args_ppc (gfc_component
*dest
, gfc_symbol
*src
)
4122 gfc_formal_arglist
*head
= NULL
;
4123 gfc_formal_arglist
*tail
= NULL
;
4124 gfc_formal_arglist
*formal_arg
= NULL
;
4125 gfc_formal_arglist
*curr_arg
= NULL
;
4126 gfc_formal_arglist
*formal_prev
= NULL
;
4127 /* Save current namespace so we can change it for formal args. */
4128 gfc_namespace
*parent_ns
= gfc_current_ns
;
4130 /* Create a new namespace, which will be the formal ns (namespace
4131 of the formal args). */
4132 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4133 /* TODO: gfc_current_ns->proc_name = dest;*/
4135 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4137 formal_arg
= gfc_get_formal_arglist ();
4138 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4140 /* May need to copy more info for the symbol. */
4141 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4142 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4143 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4144 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4146 /* If this isn't the first arg, set up the next ptr. For the
4147 last arg built, the formal_arg->next will never get set to
4148 anything other than NULL. */
4149 if (formal_prev
!= NULL
)
4150 formal_prev
->next
= formal_arg
;
4152 formal_arg
->next
= NULL
;
4154 formal_prev
= formal_arg
;
4156 /* Add arg to list of formal args. */
4157 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4160 /* Add the interface to the symbol. */
4161 dest
->formal
= head
;
4162 dest
->attr
.if_source
= IFSRC_DECL
;
4164 /* Store the formal namespace information. */
4165 if (dest
->formal
!= NULL
)
4166 /* The current ns should be that for the dest proc. */
4167 dest
->formal_ns
= gfc_current_ns
;
4168 /* Restore the current namespace to what it was on entry. */
4169 gfc_current_ns
= parent_ns
;
4173 /* Builds the parameter list for the iso_c_binding procedure
4174 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4175 generic version of either the c_f_pointer or c_f_procpointer
4176 functions. The new_proc_sym represents a "resolved" version of the
4177 symbol. The functions are resolved to match the types of their
4178 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4179 something similar to c_f_pointer_i4 if the type of data object fptr
4180 pointed to was a default integer. The actual name of the resolved
4181 procedure symbol is further mangled with the module name, etc., but
4182 the idea holds true. */
4185 build_formal_args (gfc_symbol
*new_proc_sym
,
4186 gfc_symbol
*old_sym
, int add_optional_arg
)
4188 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
4189 gfc_namespace
*parent_ns
= NULL
;
4191 parent_ns
= gfc_current_ns
;
4192 /* Create a new namespace, which will be the formal ns (namespace
4193 of the formal args). */
4194 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
4195 gfc_current_ns
->proc_name
= new_proc_sym
;
4197 /* Generate the params. */
4198 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
4200 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4201 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4202 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4203 gfc_current_ns
, "fptr", 1);
4205 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
4207 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4208 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4209 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4210 gfc_current_ns
, "fptr", 0);
4211 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4212 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
4213 gfc_current_ns
, "shape");
4216 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
4218 /* c_associated has one required arg and one optional; both
4220 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4221 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
4222 if (add_optional_arg
)
4224 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4225 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
4226 /* The last param is optional so mark it as such. */
4227 tail
->sym
->attr
.optional
= 1;
4231 /* Add the interface (store formal args to new_proc_sym). */
4232 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
4234 /* Set up the formal_ns pointer to the one created for the
4235 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4236 new_proc_sym
->formal_ns
= gfc_current_ns
;
4238 gfc_current_ns
= parent_ns
;
4242 std_for_isocbinding_symbol (int id
)
4246 #define NAMED_INTCST(a,b,c,d) \
4249 #include "iso-c-binding.def"
4252 return GFC_STD_F2003
;
4256 /* Generate the given set of C interoperable kind objects, or all
4257 interoperable kinds. This function will only be given kind objects
4258 for valid iso_c_binding defined types because this is verified when
4259 the 'use' statement is parsed. If the user gives an 'only' clause,
4260 the specific kinds are looked up; if they don't exist, an error is
4261 reported. If the user does not give an 'only' clause, all
4262 iso_c_binding symbols are generated. If a list of specific kinds
4263 is given, it must have a NULL in the first empty spot to mark the
4268 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4269 const char *local_name
)
4271 const char *const name
= (local_name
&& local_name
[0]) ? local_name
4272 : c_interop_kinds_table
[s
].name
;
4273 gfc_symtree
*tmp_symtree
= NULL
;
4274 gfc_symbol
*tmp_sym
= NULL
;
4275 gfc_dt_list
**dt_list_ptr
= NULL
;
4276 gfc_component
*tmp_comp
= NULL
;
4277 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
4280 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4282 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4284 /* Already exists in this scope so don't re-add it.
4285 TODO: we should probably check that it's really the same symbol. */
4286 if (tmp_symtree
!= NULL
)
4289 /* Create the sym tree in the current ns. */
4290 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4292 tmp_sym
= tmp_symtree
->n
.sym
;
4294 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4297 /* Say what module this symbol belongs to. */
4298 tmp_sym
->module
= gfc_get_string (mod_name
);
4299 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4300 tmp_sym
->intmod_sym_id
= s
;
4305 #define NAMED_INTCST(a,b,c,d) case a :
4306 #define NAMED_REALCST(a,b,c) case a :
4307 #define NAMED_CMPXCST(a,b,c) case a :
4308 #define NAMED_LOGCST(a,b,c) case a :
4309 #define NAMED_CHARKNDCST(a,b,c) case a :
4310 #include "iso-c-binding.def"
4312 tmp_sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
4313 c_interop_kinds_table
[s
].value
);
4315 /* Initialize an integer constant expression node. */
4316 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4317 tmp_sym
->ts
.type
= BT_INTEGER
;
4318 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4320 /* Mark this type as a C interoperable one. */
4321 tmp_sym
->ts
.is_c_interop
= 1;
4322 tmp_sym
->ts
.is_iso_c
= 1;
4323 tmp_sym
->value
->ts
.is_c_interop
= 1;
4324 tmp_sym
->value
->ts
.is_iso_c
= 1;
4325 tmp_sym
->attr
.is_c_interop
= 1;
4327 /* Tell what f90 type this c interop kind is valid. */
4328 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4330 /* Say it's from the iso_c_binding module. */
4331 tmp_sym
->attr
.is_iso_c
= 1;
4333 /* Make it use associated. */
4334 tmp_sym
->attr
.use_assoc
= 1;
4338 #define NAMED_CHARCST(a,b,c) case a :
4339 #include "iso-c-binding.def"
4341 /* Initialize an integer constant expression node for the
4342 length of the character. */
4343 tmp_sym
->value
= gfc_get_character_expr (gfc_default_character_kind
,
4344 &gfc_current_locus
, NULL
, 1);
4345 tmp_sym
->value
->ts
.is_c_interop
= 1;
4346 tmp_sym
->value
->ts
.is_iso_c
= 1;
4347 tmp_sym
->value
->value
.character
.length
= 1;
4348 tmp_sym
->value
->value
.character
.string
[0]
4349 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4350 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4351 tmp_sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4354 /* May not need this in both attr and ts, but do need in
4355 attr for writing module file. */
4356 tmp_sym
->attr
.is_c_interop
= 1;
4358 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4359 tmp_sym
->ts
.type
= BT_CHARACTER
;
4361 /* Need to set it to the C_CHAR kind. */
4362 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4364 /* Mark this type as a C interoperable one. */
4365 tmp_sym
->ts
.is_c_interop
= 1;
4366 tmp_sym
->ts
.is_iso_c
= 1;
4368 /* Tell what f90 type this c interop kind is valid. */
4369 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4371 /* Say it's from the iso_c_binding module. */
4372 tmp_sym
->attr
.is_iso_c
= 1;
4374 /* Make it use associated. */
4375 tmp_sym
->attr
.use_assoc
= 1;
4378 case ISOCBINDING_PTR
:
4379 case ISOCBINDING_FUNPTR
:
4381 /* Initialize an integer constant expression node. */
4382 tmp_sym
->attr
.flavor
= FL_DERIVED
;
4383 tmp_sym
->ts
.is_c_interop
= 1;
4384 tmp_sym
->attr
.is_c_interop
= 1;
4385 tmp_sym
->attr
.is_iso_c
= 1;
4386 tmp_sym
->ts
.is_iso_c
= 1;
4387 tmp_sym
->ts
.type
= BT_DERIVED
;
4389 /* A derived type must have the bind attribute to be
4390 interoperable (J3/04-007, Section 15.2.3), even though
4391 the binding label is not used. */
4392 tmp_sym
->attr
.is_bind_c
= 1;
4394 tmp_sym
->attr
.referenced
= 1;
4396 tmp_sym
->ts
.u
.derived
= tmp_sym
;
4398 /* Add the symbol created for the derived type to the current ns. */
4399 dt_list_ptr
= &(gfc_derived_types
);
4400 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4401 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4403 /* There is already at least one derived type in the list, so append
4404 the one we're currently building for c_ptr or c_funptr. */
4405 if (*dt_list_ptr
!= NULL
)
4406 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4407 (*dt_list_ptr
) = gfc_get_dt_list ();
4408 (*dt_list_ptr
)->derived
= tmp_sym
;
4409 (*dt_list_ptr
)->next
= NULL
;
4411 /* Set up the component of the derived type, which will be
4412 an integer with kind equal to c_ptr_size. Mangle the name of
4413 the field for the c_address to prevent the curious user from
4414 trying to access it from Fortran. */
4415 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
4416 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
4417 if (tmp_comp
== NULL
)
4418 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4419 "create component for c_address");
4421 tmp_comp
->ts
.type
= BT_INTEGER
;
4423 /* Set this because the module will need to read/write this field. */
4424 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4426 /* The kinds for c_ptr and c_funptr are the same. */
4427 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4428 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4430 tmp_comp
->attr
.pointer
= 0;
4431 tmp_comp
->attr
.dimension
= 0;
4433 /* Mark the component as C interoperable. */
4434 tmp_comp
->ts
.is_c_interop
= 1;
4436 /* Make it use associated (iso_c_binding module). */
4437 tmp_sym
->attr
.use_assoc
= 1;
4440 case ISOCBINDING_NULL_PTR
:
4441 case ISOCBINDING_NULL_FUNPTR
:
4442 gen_special_c_interop_ptr (s
, name
, mod_name
);
4445 case ISOCBINDING_F_POINTER
:
4446 case ISOCBINDING_ASSOCIATED
:
4447 case ISOCBINDING_LOC
:
4448 case ISOCBINDING_FUNLOC
:
4449 case ISOCBINDING_F_PROCPOINTER
:
4451 tmp_sym
->attr
.proc
= PROC_MODULE
;
4453 /* Use the procedure's name as it is in the iso_c_binding module for
4454 setting the binding label in case the user renamed the symbol. */
4455 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
4456 c_interop_kinds_table
[s
].name
);
4457 tmp_sym
->attr
.is_iso_c
= 1;
4458 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4459 tmp_sym
->attr
.subroutine
= 1;
4462 /* TODO! This needs to be finished more for the expr of the
4463 function or something!
4464 This may not need to be here, because trying to do c_loc
4466 if (s
== ISOCBINDING_ASSOCIATED
)
4468 tmp_sym
->attr
.function
= 1;
4469 tmp_sym
->ts
.type
= BT_LOGICAL
;
4470 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4471 tmp_sym
->result
= tmp_sym
;
4475 /* Here, we're taking the simple approach. We're defining
4476 c_loc as an external identifier so the compiler will put
4477 what we expect on the stack for the address we want the
4479 tmp_sym
->ts
.type
= BT_DERIVED
;
4480 if (s
== ISOCBINDING_LOC
)
4481 tmp_sym
->ts
.u
.derived
=
4482 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4484 tmp_sym
->ts
.u
.derived
=
4485 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4487 if (tmp_sym
->ts
.u
.derived
== NULL
)
4489 /* Create the necessary derived type so we can continue
4490 processing the file. */
4491 generate_isocbinding_symbol
4492 (mod_name
, s
== ISOCBINDING_FUNLOC
4493 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4494 (const char *)(s
== ISOCBINDING_FUNLOC
4495 ? "_gfortran_iso_c_binding_c_funptr"
4496 : "_gfortran_iso_c_binding_c_ptr"));
4497 tmp_sym
->ts
.u
.derived
=
4498 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4499 ? ISOCBINDING_FUNPTR
4503 /* The function result is itself (no result clause). */
4504 tmp_sym
->result
= tmp_sym
;
4505 tmp_sym
->attr
.external
= 1;
4506 tmp_sym
->attr
.use_assoc
= 0;
4507 tmp_sym
->attr
.pure
= 1;
4508 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4509 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4513 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4514 tmp_sym
->attr
.contained
= 0;
4516 /* Try using this builder routine, with the new and old symbols
4517 both being the generic iso_c proc sym being created. This
4518 will create the formal args (and the new namespace for them).
4519 Don't build an arg list for c_loc because we're going to treat
4520 c_loc as an external procedure. */
4521 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4522 /* The 1 says to add any optional args, if applicable. */
4523 build_formal_args (tmp_sym
, tmp_sym
, 1);
4525 /* Set this after setting up the symbol, to prevent error messages. */
4526 tmp_sym
->attr
.use_assoc
= 1;
4528 /* This symbol will not be referenced directly. It will be
4529 resolved to the implementation for the given f90 kind. */
4530 tmp_sym
->attr
.referenced
= 0;
4540 /* Creates a new symbol based off of an old iso_c symbol, with a new
4541 binding label. This function can be used to create a new,
4542 resolved, version of a procedure symbol for c_f_pointer or
4543 c_f_procpointer that is based on the generic symbols. A new
4544 parameter list is created for the new symbol using
4545 build_formal_args(). The add_optional_flag specifies whether the
4546 to add the optional SHAPE argument. The new symbol is
4550 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4551 char *new_binding_label
, int add_optional_arg
)
4553 gfc_symtree
*new_symtree
= NULL
;
4555 /* See if we have a symbol by that name already available, looking
4556 through any parent namespaces. */
4557 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4558 if (new_symtree
!= NULL
)
4559 /* Return the existing symbol. */
4560 return new_symtree
->n
.sym
;
4562 /* Create the symtree/symbol, with attempted host association. */
4563 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4564 if (new_symtree
== NULL
)
4565 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4566 "symtree for '%s'", new_name
);
4568 /* Now fill in the fields of the resolved symbol with the old sym. */
4569 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4570 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4571 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4572 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4573 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4574 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4575 if (old_sym
->attr
.function
)
4576 new_symtree
->n
.sym
->result
= new_symtree
->n
.sym
;
4577 /* Build the formal arg list. */
4578 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4580 gfc_commit_symbol (new_symtree
->n
.sym
);
4582 return new_symtree
->n
.sym
;
4586 /* Check that a symbol is already typed. If strict is not set, an untyped
4587 symbol is acceptable for non-standard-conforming mode. */
4590 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4591 bool strict
, locus where
)
4595 if (gfc_matching_prefix
)
4598 /* Check for the type and try to give it an implicit one. */
4599 if (sym
->ts
.type
== BT_UNKNOWN
4600 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4604 gfc_error ("Symbol '%s' is used before it is typed at %L",
4609 if (gfc_notify_std (GFC_STD_GNU
,
4610 "Extension: Symbol '%s' is used before"
4611 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4615 /* Everything is ok. */
4620 /* Construct a typebound-procedure structure. Those are stored in a tentative
4621 list and marked `error' until symbols are committed. */
4624 gfc_get_typebound_proc (gfc_typebound_proc
*tb0
)
4626 gfc_typebound_proc
*result
;
4627 tentative_tbp
*list_node
;
4629 result
= XCNEW (gfc_typebound_proc
);
4634 list_node
= XCNEW (tentative_tbp
);
4635 list_node
->next
= tentative_tbp_list
;
4636 list_node
->proc
= result
;
4637 tentative_tbp_list
= list_node
;
4643 /* Get the super-type of a given derived type. */
4646 gfc_get_derived_super_type (gfc_symbol
* derived
)
4648 if (!derived
->attr
.extension
)
4651 gcc_assert (derived
->components
);
4652 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4653 gcc_assert (derived
->components
->ts
.u
.derived
);
4655 return derived
->components
->ts
.u
.derived
;
4659 /* Get the ultimate super-type of a given derived type. */
4662 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4664 if (!derived
->attr
.extension
)
4667 derived
= gfc_get_derived_super_type (derived
);
4669 if (derived
->attr
.extension
)
4670 return gfc_get_ultimate_derived_super_type (derived
);
4676 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4679 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4681 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4682 t2
= gfc_get_derived_super_type (t2
);
4683 return gfc_compare_derived_types (t1
, t2
);
4687 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4688 If ts1 is nonpolymorphic, ts2 must be the same type.
4689 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4692 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4694 bool is_class1
= (ts1
->type
== BT_CLASS
);
4695 bool is_class2
= (ts2
->type
== BT_CLASS
);
4696 bool is_derived1
= (ts1
->type
== BT_DERIVED
);
4697 bool is_derived2
= (ts2
->type
== BT_DERIVED
);
4699 if (!is_derived1
&& !is_derived2
&& !is_class1
&& !is_class2
)
4700 return (ts1
->type
== ts2
->type
);
4702 if (is_derived1
&& is_derived2
)
4703 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4705 if (is_class1
&& is_derived2
)
4706 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4708 else if (is_class1
&& is_class2
)
4709 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4710 ts2
->u
.derived
->components
->ts
.u
.derived
);