1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors
[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN
), minit ("PROGRAM", FL_PROGRAM
),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA
), minit ("MODULE", FL_MODULE
),
39 minit ("VARIABLE", FL_VARIABLE
), minit ("PARAMETER", FL_PARAMETER
),
40 minit ("LABEL", FL_LABEL
), minit ("PROCEDURE", FL_PROCEDURE
),
41 minit ("DERIVED", FL_DERIVED
), minit ("NAMELIST", FL_NAMELIST
),
45 const mstring procedures
[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN
),
48 minit ("MODULE-PROC", PROC_MODULE
),
49 minit ("INTERNAL-PROC", PROC_INTERNAL
),
50 minit ("DUMMY-PROC", PROC_DUMMY
),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC
),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL
),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION
),
57 const mstring intents
[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN
),
60 minit ("IN", INTENT_IN
),
61 minit ("OUT", INTENT_OUT
),
62 minit ("INOUT", INTENT_INOUT
),
66 const mstring access_types
[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN
),
69 minit ("PUBLIC", ACCESS_PUBLIC
),
70 minit ("PRIVATE", ACCESS_PRIVATE
),
74 const mstring ifsrc_types
[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN
),
77 minit ("DECL", IFSRC_DECL
),
78 minit ("BODY", IFSRC_IFBODY
)
81 const mstring save_status
[] =
83 minit ("UNKNOWN", SAVE_NONE
),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT
),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT
),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order
= 1;
94 gfc_namespace
*gfc_current_ns
;
95 gfc_namespace
*gfc_global_ns_list
;
97 gfc_gsymbol
*gfc_gsym_root
= NULL
;
99 static gfc_symbol
*changed_syms
= NULL
;
101 gfc_dt_list
*gfc_derived_types
;
104 /* List of tentative typebound-procedures. */
106 typedef struct tentative_tbp
108 gfc_typebound_proc
*proc
;
109 struct tentative_tbp
*next
;
113 static tentative_tbp
*tentative_tbp_list
= NULL
;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag
[GFC_LETTERS
];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (void)
131 if (gfc_current_ns
->seen_implicit_none
)
133 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
137 gfc_current_ns
->seen_implicit_none
= 1;
139 for (i
= 0; i
< GFC_LETTERS
; i
++)
141 gfc_clear_ts (&gfc_current_ns
->default_type
[i
]);
142 gfc_current_ns
->set_flag
[i
] = 1;
147 /* Reset the implicit range flags. */
150 gfc_clear_new_implicit (void)
154 for (i
= 0; i
< GFC_LETTERS
; i
++)
159 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
162 gfc_add_new_implicit_range (int c1
, int c2
)
169 for (i
= c1
; i
<= c2
; i
++)
173 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
185 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
186 the new implicit types back into the existing types will work. */
189 gfc_merge_new_implicit (gfc_typespec
*ts
)
193 if (gfc_current_ns
->seen_implicit_none
)
195 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
199 for (i
= 0; i
< GFC_LETTERS
; i
++)
203 if (gfc_current_ns
->set_flag
[i
])
205 gfc_error ("Letter %c already has an IMPLICIT type at %C",
210 gfc_current_ns
->default_type
[i
] = *ts
;
211 gfc_current_ns
->implicit_loc
[i
] = gfc_current_locus
;
212 gfc_current_ns
->set_flag
[i
] = 1;
219 /* Given a symbol, return a pointer to the typespec for its default type. */
222 gfc_get_default_type (const char *name
, gfc_namespace
*ns
)
228 if (gfc_option
.flag_allow_leading_underscore
&& letter
== '_')
229 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
230 "gfortran developers, and should not be used for "
231 "implicitly typed variables");
233 if (letter
< 'a' || letter
> 'z')
234 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name
);
239 return &ns
->default_type
[letter
- 'a'];
243 /* Given a pointer to a symbol, set its type according to the first
244 letter of its name. Fails if the letter in question has no default
248 gfc_set_default_type (gfc_symbol
*sym
, int error_flag
, gfc_namespace
*ns
)
252 if (sym
->ts
.type
!= BT_UNKNOWN
)
253 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
255 ts
= gfc_get_default_type (sym
->name
, ns
);
257 if (ts
->type
== BT_UNKNOWN
)
259 if (error_flag
&& !sym
->attr
.untyped
)
261 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
262 sym
->name
, &sym
->declared_at
);
263 sym
->attr
.untyped
= 1; /* Ensure we only give an error once. */
270 sym
->attr
.implicit_type
= 1;
272 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
)
273 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ts
->u
.cl
);
275 if (sym
->attr
.is_bind_c
== 1)
277 /* BIND(C) variables should not be implicitly declared. */
278 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
279 "not be C interoperable", sym
->name
, &sym
->declared_at
);
280 sym
->ts
.f90_type
= sym
->ts
.type
;
283 if (sym
->attr
.dummy
!= 0)
285 if (sym
->ns
->proc_name
!= NULL
286 && (sym
->ns
->proc_name
->attr
.subroutine
!= 0
287 || sym
->ns
->proc_name
->attr
.function
!= 0)
288 && sym
->ns
->proc_name
->attr
.is_bind_c
!= 0)
290 /* Dummy args to a BIND(C) routine may not be interoperable if
291 they are implicitly typed. */
292 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
293 "be C interoperable but it is a dummy argument to "
294 "the BIND(C) procedure '%s' at %L", sym
->name
,
295 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
296 &(sym
->ns
->proc_name
->declared_at
));
297 sym
->ts
.f90_type
= sym
->ts
.type
;
305 /* This function is called from parse.c(parse_progunit) to check the
306 type of the function is not implicitly typed in the host namespace
307 and to implicitly type the function result, if necessary. */
310 gfc_check_function_type (gfc_namespace
*ns
)
312 gfc_symbol
*proc
= ns
->proc_name
;
314 if (!proc
->attr
.contained
|| proc
->result
->attr
.implicit_type
)
317 if (proc
->result
->ts
.type
== BT_UNKNOWN
&& proc
->result
->ts
.interface
== NULL
)
319 if (gfc_set_default_type (proc
->result
, 0, gfc_current_ns
)
322 if (proc
->result
!= proc
)
324 proc
->ts
= proc
->result
->ts
;
325 proc
->as
= gfc_copy_array_spec (proc
->result
->as
);
326 proc
->attr
.dimension
= proc
->result
->attr
.dimension
;
327 proc
->attr
.pointer
= proc
->result
->attr
.pointer
;
328 proc
->attr
.allocatable
= proc
->result
->attr
.allocatable
;
331 else if (!proc
->result
->attr
.proc_pointer
)
333 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
334 proc
->result
->name
, &proc
->result
->declared_at
);
335 proc
->result
->attr
.untyped
= 1;
341 /******************** Symbol attribute stuff *********************/
343 /* This is a generic conflict-checker. We do this to avoid having a
344 single conflict in two places. */
346 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
347 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
348 #define conf_std(a, b, std) if (attr->a && attr->b)\
357 check_conflict (symbol_attribute
*attr
, const char *name
, locus
*where
)
359 static const char *dummy
= "DUMMY", *save
= "SAVE", *pointer
= "POINTER",
360 *target
= "TARGET", *external
= "EXTERNAL", *intent
= "INTENT",
361 *intent_in
= "INTENT(IN)", *intrinsic
= "INTRINSIC",
362 *intent_out
= "INTENT(OUT)", *intent_inout
= "INTENT(INOUT)",
363 *allocatable
= "ALLOCATABLE", *elemental
= "ELEMENTAL",
364 *privat
= "PRIVATE", *recursive
= "RECURSIVE",
365 *in_common
= "COMMON", *result
= "RESULT", *in_namelist
= "NAMELIST",
366 *publik
= "PUBLIC", *optional
= "OPTIONAL", *entry
= "ENTRY",
367 *function
= "FUNCTION", *subroutine
= "SUBROUTINE",
368 *dimension
= "DIMENSION", *in_equivalence
= "EQUIVALENCE",
369 *use_assoc
= "USE ASSOCIATED", *cray_pointer
= "CRAY POINTER",
370 *cray_pointee
= "CRAY POINTEE", *data
= "DATA", *value
= "VALUE",
371 *volatile_
= "VOLATILE", *is_protected
= "PROTECTED",
372 *is_bind_c
= "BIND(C)", *procedure
= "PROCEDURE";
373 static const char *threadprivate
= "THREADPRIVATE";
379 where
= &gfc_current_locus
;
381 if (attr
->pointer
&& attr
->intent
!= INTENT_UNKNOWN
)
385 standard
= GFC_STD_F2003
;
389 /* Check for attributes not allowed in a BLOCK DATA. */
390 if (gfc_current_state () == COMP_BLOCK_DATA
)
394 if (attr
->in_namelist
)
396 if (attr
->allocatable
)
402 if (attr
->access
== ACCESS_PRIVATE
)
404 if (attr
->access
== ACCESS_PUBLIC
)
406 if (attr
->intent
!= INTENT_UNKNOWN
)
412 ("%s attribute not allowed in BLOCK DATA program unit at %L",
418 if (attr
->save
== SAVE_EXPLICIT
)
421 conf (in_common
, save
);
424 switch (attr
->flavor
)
432 a1
= gfc_code2string (flavors
, attr
->flavor
);
437 /* Conflicts between SAVE and PROCEDURE will be checked at
438 resolution stage, see "resolve_fl_procedure". */
447 conf (dummy
, intrinsic
);
448 conf (dummy
, threadprivate
);
449 conf (pointer
, target
);
450 conf (pointer
, intrinsic
);
451 conf (pointer
, elemental
);
452 conf (allocatable
, elemental
);
454 conf (target
, external
);
455 conf (target
, intrinsic
);
457 if (!attr
->if_source
)
458 conf (external
, dimension
); /* See Fortran 95's R504. */
460 conf (external
, intrinsic
);
461 conf (entry
, intrinsic
);
463 if ((attr
->if_source
== IFSRC_DECL
&& !attr
->procedure
) || attr
->contained
)
464 conf (external
, subroutine
);
466 if (attr
->proc_pointer
&& gfc_notify_std (GFC_STD_F2003
,
467 "Fortran 2003: Procedure pointer at %C") == FAILURE
)
470 conf (allocatable
, pointer
);
471 conf_std (allocatable
, dummy
, GFC_STD_F2003
);
472 conf_std (allocatable
, function
, GFC_STD_F2003
);
473 conf_std (allocatable
, result
, GFC_STD_F2003
);
474 conf (elemental
, recursive
);
476 conf (in_common
, dummy
);
477 conf (in_common
, allocatable
);
478 conf (in_common
, result
);
480 conf (dummy
, result
);
482 conf (in_equivalence
, use_assoc
);
483 conf (in_equivalence
, dummy
);
484 conf (in_equivalence
, target
);
485 conf (in_equivalence
, pointer
);
486 conf (in_equivalence
, function
);
487 conf (in_equivalence
, result
);
488 conf (in_equivalence
, entry
);
489 conf (in_equivalence
, allocatable
);
490 conf (in_equivalence
, threadprivate
);
492 conf (in_namelist
, pointer
);
493 conf (in_namelist
, allocatable
);
495 conf (entry
, result
);
497 conf (function
, subroutine
);
499 if (!function
&& !subroutine
)
500 conf (is_bind_c
, dummy
);
502 conf (is_bind_c
, cray_pointer
);
503 conf (is_bind_c
, cray_pointee
);
504 conf (is_bind_c
, allocatable
);
505 conf (is_bind_c
, elemental
);
507 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
508 Parameter conflict caught below. Also, value cannot be specified
509 for a dummy procedure. */
511 /* Cray pointer/pointee conflicts. */
512 conf (cray_pointer
, cray_pointee
);
513 conf (cray_pointer
, dimension
);
514 conf (cray_pointer
, pointer
);
515 conf (cray_pointer
, target
);
516 conf (cray_pointer
, allocatable
);
517 conf (cray_pointer
, external
);
518 conf (cray_pointer
, intrinsic
);
519 conf (cray_pointer
, in_namelist
);
520 conf (cray_pointer
, function
);
521 conf (cray_pointer
, subroutine
);
522 conf (cray_pointer
, entry
);
524 conf (cray_pointee
, allocatable
);
525 conf (cray_pointee
, intent
);
526 conf (cray_pointee
, optional
);
527 conf (cray_pointee
, dummy
);
528 conf (cray_pointee
, target
);
529 conf (cray_pointee
, intrinsic
);
530 conf (cray_pointee
, pointer
);
531 conf (cray_pointee
, entry
);
532 conf (cray_pointee
, in_common
);
533 conf (cray_pointee
, in_equivalence
);
534 conf (cray_pointee
, threadprivate
);
537 conf (data
, function
);
539 conf (data
, allocatable
);
540 conf (data
, use_assoc
);
542 conf (value
, pointer
)
543 conf (value
, allocatable
)
544 conf (value
, subroutine
)
545 conf (value
, function
)
546 conf (value
, volatile_
)
547 conf (value
, dimension
)
548 conf (value
, external
)
551 && (attr
->intent
== INTENT_OUT
|| attr
->intent
== INTENT_INOUT
))
554 a2
= attr
->intent
== INTENT_OUT
? intent_out
: intent_inout
;
558 conf (is_protected
, intrinsic
)
559 conf (is_protected
, external
)
560 conf (is_protected
, in_common
)
562 conf (volatile_
, intrinsic
)
563 conf (volatile_
, external
)
565 if (attr
->volatile_
&& attr
->intent
== INTENT_IN
)
572 conf (procedure
, allocatable
)
573 conf (procedure
, dimension
)
574 conf (procedure
, intrinsic
)
575 conf (procedure
, is_protected
)
576 conf (procedure
, target
)
577 conf (procedure
, value
)
578 conf (procedure
, volatile_
)
579 conf (procedure
, entry
)
581 a1
= gfc_code2string (flavors
, attr
->flavor
);
583 if (attr
->in_namelist
584 && attr
->flavor
!= FL_VARIABLE
585 && attr
->flavor
!= FL_PROCEDURE
586 && attr
->flavor
!= FL_UNKNOWN
)
592 switch (attr
->flavor
)
602 conf2 (is_protected
);
612 conf2 (threadprivate
);
614 if (attr
->access
== ACCESS_PUBLIC
|| attr
->access
== ACCESS_PRIVATE
)
616 a2
= attr
->access
== ACCESS_PUBLIC
? publik
: privat
;
617 gfc_error ("%s attribute applied to %s %s at %L", a2
, a1
,
624 gfc_error_now ("BIND(C) applied to %s %s at %L", a1
, name
, where
);
638 /* Conflicts with INTENT, SAVE and RESULT will be checked
639 at resolution stage, see "resolve_fl_procedure". */
641 if (attr
->subroutine
)
648 conf2 (threadprivate
);
651 if (!attr
->proc_pointer
)
656 case PROC_ST_FUNCTION
:
666 conf2 (threadprivate
);
686 conf2 (threadprivate
);
689 if (attr
->intent
!= INTENT_UNKNOWN
)
705 conf2 (is_protected
);
711 conf2 (threadprivate
);
725 gfc_error ("%s attribute conflicts with %s attribute at %L",
728 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
729 a1
, a2
, name
, where
);
736 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
737 "with %s attribute at %L", a1
, a2
,
742 return gfc_notify_std (standard
, "Fortran 2003: %s attribute "
743 "with %s attribute in '%s' at %L",
744 a1
, a2
, name
, where
);
753 /* Mark a symbol as referenced. */
756 gfc_set_sym_referenced (gfc_symbol
*sym
)
759 if (sym
->attr
.referenced
)
762 sym
->attr
.referenced
= 1;
764 /* Remember which order dummy variables are accessed in. */
766 sym
->dummy_order
= next_dummy_order
++;
770 /* Common subroutine called by attribute changing subroutines in order
771 to prevent them from changing a symbol that has been
772 use-associated. Returns zero if it is OK to change the symbol,
776 check_used (symbol_attribute
*attr
, const char *name
, locus
*where
)
779 if (attr
->use_assoc
== 0)
783 where
= &gfc_current_locus
;
786 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
789 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
796 /* Generate an error because of a duplicate attribute. */
799 duplicate_attr (const char *attr
, locus
*where
)
803 where
= &gfc_current_locus
;
805 gfc_error ("Duplicate %s attribute specified at %L", attr
, where
);
810 gfc_add_ext_attribute (symbol_attribute
*attr
, ext_attr_id_t ext_attr
,
811 locus
*where ATTRIBUTE_UNUSED
)
813 attr
->ext_attr
|= 1 << ext_attr
;
818 /* Called from decl.c (attr_decl1) to check attributes, when declared
822 gfc_add_attribute (symbol_attribute
*attr
, locus
*where
)
824 if (check_used (attr
, NULL
, where
))
827 return check_conflict (attr
, NULL
, where
);
832 gfc_add_allocatable (symbol_attribute
*attr
, locus
*where
)
835 if (check_used (attr
, NULL
, where
))
838 if (attr
->allocatable
)
840 duplicate_attr ("ALLOCATABLE", where
);
844 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
845 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
847 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
852 attr
->allocatable
= 1;
853 return check_conflict (attr
, NULL
, where
);
858 gfc_add_dimension (symbol_attribute
*attr
, const char *name
, locus
*where
)
861 if (check_used (attr
, name
, where
))
866 duplicate_attr ("DIMENSION", where
);
870 if (attr
->flavor
== FL_PROCEDURE
&& attr
->if_source
== IFSRC_IFBODY
871 && gfc_find_state (COMP_INTERFACE
) == FAILURE
)
873 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
874 "at %L", name
, where
);
879 return check_conflict (attr
, name
, where
);
884 gfc_add_external (symbol_attribute
*attr
, locus
*where
)
887 if (check_used (attr
, NULL
, where
))
892 duplicate_attr ("EXTERNAL", where
);
896 if (attr
->pointer
&& attr
->if_source
!= IFSRC_IFBODY
)
899 attr
->proc_pointer
= 1;
904 return check_conflict (attr
, NULL
, where
);
909 gfc_add_intrinsic (symbol_attribute
*attr
, locus
*where
)
912 if (check_used (attr
, NULL
, where
))
917 duplicate_attr ("INTRINSIC", where
);
923 return check_conflict (attr
, NULL
, where
);
928 gfc_add_optional (symbol_attribute
*attr
, locus
*where
)
931 if (check_used (attr
, NULL
, where
))
936 duplicate_attr ("OPTIONAL", where
);
941 return check_conflict (attr
, NULL
, where
);
946 gfc_add_pointer (symbol_attribute
*attr
, locus
*where
)
949 if (check_used (attr
, NULL
, where
))
952 if (attr
->pointer
&& !(attr
->if_source
== IFSRC_IFBODY
953 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
955 duplicate_attr ("POINTER", where
);
959 if (attr
->procedure
|| (attr
->external
&& attr
->if_source
!= IFSRC_IFBODY
)
960 || (attr
->if_source
== IFSRC_IFBODY
961 && gfc_find_state (COMP_INTERFACE
) == FAILURE
))
962 attr
->proc_pointer
= 1;
966 return check_conflict (attr
, NULL
, where
);
971 gfc_add_cray_pointer (symbol_attribute
*attr
, locus
*where
)
974 if (check_used (attr
, NULL
, where
))
977 attr
->cray_pointer
= 1;
978 return check_conflict (attr
, NULL
, where
);
983 gfc_add_cray_pointee (symbol_attribute
*attr
, locus
*where
)
986 if (check_used (attr
, NULL
, where
))
989 if (attr
->cray_pointee
)
991 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
992 " statements", where
);
996 attr
->cray_pointee
= 1;
997 return check_conflict (attr
, NULL
, where
);
1002 gfc_add_protected (symbol_attribute
*attr
, const char *name
, locus
*where
)
1004 if (check_used (attr
, name
, where
))
1007 if (attr
->is_protected
)
1009 if (gfc_notify_std (GFC_STD_LEGACY
,
1010 "Duplicate PROTECTED attribute specified at %L",
1016 attr
->is_protected
= 1;
1017 return check_conflict (attr
, name
, where
);
1022 gfc_add_result (symbol_attribute
*attr
, const char *name
, locus
*where
)
1025 if (check_used (attr
, name
, where
))
1029 return check_conflict (attr
, name
, where
);
1034 gfc_add_save (symbol_attribute
*attr
, const char *name
, locus
*where
)
1037 if (check_used (attr
, name
, where
))
1040 if (gfc_pure (NULL
))
1043 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1048 if (attr
->save
== SAVE_EXPLICIT
)
1050 if (gfc_notify_std (GFC_STD_LEGACY
,
1051 "Duplicate SAVE attribute specified at %L",
1057 attr
->save
= SAVE_EXPLICIT
;
1058 return check_conflict (attr
, name
, where
);
1063 gfc_add_value (symbol_attribute
*attr
, const char *name
, locus
*where
)
1066 if (check_used (attr
, name
, where
))
1071 if (gfc_notify_std (GFC_STD_LEGACY
,
1072 "Duplicate VALUE attribute specified at %L",
1079 return check_conflict (attr
, name
, where
);
1084 gfc_add_volatile (symbol_attribute
*attr
, const char *name
, locus
*where
)
1086 /* No check_used needed as 11.2.1 of the F2003 standard allows
1087 that the local identifier made accessible by a use statement can be
1088 given a VOLATILE attribute. */
1090 if (attr
->volatile_
&& attr
->volatile_ns
== gfc_current_ns
)
1091 if (gfc_notify_std (GFC_STD_LEGACY
,
1092 "Duplicate VOLATILE attribute specified at %L", where
)
1096 attr
->volatile_
= 1;
1097 attr
->volatile_ns
= gfc_current_ns
;
1098 return check_conflict (attr
, name
, where
);
1103 gfc_add_threadprivate (symbol_attribute
*attr
, const char *name
, locus
*where
)
1106 if (check_used (attr
, name
, where
))
1109 if (attr
->threadprivate
)
1111 duplicate_attr ("THREADPRIVATE", where
);
1115 attr
->threadprivate
= 1;
1116 return check_conflict (attr
, name
, where
);
1121 gfc_add_target (symbol_attribute
*attr
, locus
*where
)
1124 if (check_used (attr
, NULL
, where
))
1129 duplicate_attr ("TARGET", where
);
1134 return check_conflict (attr
, NULL
, where
);
1139 gfc_add_dummy (symbol_attribute
*attr
, const char *name
, locus
*where
)
1142 if (check_used (attr
, name
, where
))
1145 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1147 return check_conflict (attr
, name
, where
);
1152 gfc_add_in_common (symbol_attribute
*attr
, const char *name
, locus
*where
)
1155 if (check_used (attr
, name
, where
))
1158 /* Duplicate attribute already checked for. */
1159 attr
->in_common
= 1;
1160 return check_conflict (attr
, name
, where
);
1165 gfc_add_in_equivalence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1168 /* Duplicate attribute already checked for. */
1169 attr
->in_equivalence
= 1;
1170 if (check_conflict (attr
, name
, where
) == FAILURE
)
1173 if (attr
->flavor
== FL_VARIABLE
)
1176 return gfc_add_flavor (attr
, FL_VARIABLE
, name
, where
);
1181 gfc_add_data (symbol_attribute
*attr
, const char *name
, locus
*where
)
1184 if (check_used (attr
, name
, where
))
1188 return check_conflict (attr
, name
, where
);
1193 gfc_add_in_namelist (symbol_attribute
*attr
, const char *name
, locus
*where
)
1196 attr
->in_namelist
= 1;
1197 return check_conflict (attr
, name
, where
);
1202 gfc_add_sequence (symbol_attribute
*attr
, const char *name
, locus
*where
)
1205 if (check_used (attr
, name
, where
))
1209 return check_conflict (attr
, name
, where
);
1214 gfc_add_elemental (symbol_attribute
*attr
, locus
*where
)
1217 if (check_used (attr
, NULL
, where
))
1220 if (attr
->elemental
)
1222 duplicate_attr ("ELEMENTAL", where
);
1226 attr
->elemental
= 1;
1227 return check_conflict (attr
, NULL
, where
);
1232 gfc_add_pure (symbol_attribute
*attr
, locus
*where
)
1235 if (check_used (attr
, NULL
, where
))
1240 duplicate_attr ("PURE", where
);
1245 return check_conflict (attr
, NULL
, where
);
1250 gfc_add_recursive (symbol_attribute
*attr
, locus
*where
)
1253 if (check_used (attr
, NULL
, where
))
1256 if (attr
->recursive
)
1258 duplicate_attr ("RECURSIVE", where
);
1262 attr
->recursive
= 1;
1263 return check_conflict (attr
, NULL
, where
);
1268 gfc_add_entry (symbol_attribute
*attr
, const char *name
, locus
*where
)
1271 if (check_used (attr
, name
, where
))
1276 duplicate_attr ("ENTRY", where
);
1281 return check_conflict (attr
, name
, where
);
1286 gfc_add_function (symbol_attribute
*attr
, const char *name
, locus
*where
)
1289 if (attr
->flavor
!= FL_PROCEDURE
1290 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1294 return check_conflict (attr
, name
, where
);
1299 gfc_add_subroutine (symbol_attribute
*attr
, const char *name
, locus
*where
)
1302 if (attr
->flavor
!= FL_PROCEDURE
1303 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1306 attr
->subroutine
= 1;
1307 return check_conflict (attr
, name
, where
);
1312 gfc_add_generic (symbol_attribute
*attr
, const char *name
, locus
*where
)
1315 if (attr
->flavor
!= FL_PROCEDURE
1316 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1320 return check_conflict (attr
, name
, where
);
1325 gfc_add_proc (symbol_attribute
*attr
, const char *name
, locus
*where
)
1328 if (check_used (attr
, NULL
, where
))
1331 if (attr
->flavor
!= FL_PROCEDURE
1332 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1335 if (attr
->procedure
)
1337 duplicate_attr ("PROCEDURE", where
);
1341 attr
->procedure
= 1;
1343 return check_conflict (attr
, NULL
, where
);
1348 gfc_add_abstract (symbol_attribute
* attr
, locus
* where
)
1352 duplicate_attr ("ABSTRACT", where
);
1361 /* Flavors are special because some flavors are not what Fortran
1362 considers attributes and can be reaffirmed multiple times. */
1365 gfc_add_flavor (symbol_attribute
*attr
, sym_flavor f
, const char *name
,
1369 if ((f
== FL_PROGRAM
|| f
== FL_BLOCK_DATA
|| f
== FL_MODULE
1370 || f
== FL_PARAMETER
|| f
== FL_LABEL
|| f
== FL_DERIVED
1371 || f
== FL_NAMELIST
) && check_used (attr
, name
, where
))
1374 if (attr
->flavor
== f
&& f
== FL_VARIABLE
)
1377 if (attr
->flavor
!= FL_UNKNOWN
)
1380 where
= &gfc_current_locus
;
1383 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1384 gfc_code2string (flavors
, attr
->flavor
), name
,
1385 gfc_code2string (flavors
, f
), where
);
1387 gfc_error ("%s attribute conflicts with %s attribute at %L",
1388 gfc_code2string (flavors
, attr
->flavor
),
1389 gfc_code2string (flavors
, f
), where
);
1396 return check_conflict (attr
, name
, where
);
1401 gfc_add_procedure (symbol_attribute
*attr
, procedure_type t
,
1402 const char *name
, locus
*where
)
1405 if (check_used (attr
, name
, where
))
1408 if (attr
->flavor
!= FL_PROCEDURE
1409 && gfc_add_flavor (attr
, FL_PROCEDURE
, name
, where
) == FAILURE
)
1413 where
= &gfc_current_locus
;
1415 if (attr
->proc
!= PROC_UNKNOWN
)
1417 gfc_error ("%s procedure at %L is already declared as %s procedure",
1418 gfc_code2string (procedures
, t
), where
,
1419 gfc_code2string (procedures
, attr
->proc
));
1426 /* Statement functions are always scalar and functions. */
1427 if (t
== PROC_ST_FUNCTION
1428 && ((!attr
->function
&& gfc_add_function (attr
, name
, where
) == FAILURE
)
1429 || attr
->dimension
))
1432 return check_conflict (attr
, name
, where
);
1437 gfc_add_intent (symbol_attribute
*attr
, sym_intent intent
, locus
*where
)
1440 if (check_used (attr
, NULL
, where
))
1443 if (attr
->intent
== INTENT_UNKNOWN
)
1445 attr
->intent
= intent
;
1446 return check_conflict (attr
, NULL
, where
);
1450 where
= &gfc_current_locus
;
1452 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1453 gfc_intent_string (attr
->intent
),
1454 gfc_intent_string (intent
), where
);
1460 /* No checks for use-association in public and private statements. */
1463 gfc_add_access (symbol_attribute
*attr
, gfc_access access
,
1464 const char *name
, locus
*where
)
1467 if (attr
->access
== ACCESS_UNKNOWN
1468 || (attr
->use_assoc
&& attr
->access
!= ACCESS_PRIVATE
))
1470 attr
->access
= access
;
1471 return check_conflict (attr
, name
, where
);
1475 where
= &gfc_current_locus
;
1476 gfc_error ("ACCESS specification at %L was already specified", where
);
1482 /* Set the is_bind_c field for the given symbol_attribute. */
1485 gfc_add_is_bind_c (symbol_attribute
*attr
, const char *name
, locus
*where
,
1486 int is_proc_lang_bind_spec
)
1489 if (is_proc_lang_bind_spec
== 0 && attr
->flavor
== FL_PROCEDURE
)
1490 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1491 "variables or common blocks", where
);
1492 else if (attr
->is_bind_c
)
1493 gfc_error_now ("Duplicate BIND attribute specified at %L", where
);
1495 attr
->is_bind_c
= 1;
1498 where
= &gfc_current_locus
;
1500 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BIND(C) at %L", where
)
1504 return check_conflict (attr
, name
, where
);
1508 /* Set the extension field for the given symbol_attribute. */
1511 gfc_add_extension (symbol_attribute
*attr
, locus
*where
)
1514 where
= &gfc_current_locus
;
1516 if (attr
->extension
)
1517 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where
);
1519 attr
->extension
= 1;
1521 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: EXTENDS at %L", where
)
1530 gfc_add_explicit_interface (gfc_symbol
*sym
, ifsrc source
,
1531 gfc_formal_arglist
* formal
, locus
*where
)
1534 if (check_used (&sym
->attr
, sym
->name
, where
))
1538 where
= &gfc_current_locus
;
1540 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
1541 && sym
->attr
.if_source
!= IFSRC_DECL
)
1543 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1548 if (source
== IFSRC_IFBODY
&& (sym
->attr
.dimension
|| sym
->attr
.allocatable
))
1550 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1551 "body", sym
->name
, where
);
1555 sym
->formal
= formal
;
1556 sym
->attr
.if_source
= source
;
1562 /* Add a type to a symbol. */
1565 gfc_add_type (gfc_symbol
*sym
, gfc_typespec
*ts
, locus
*where
)
1571 where
= &gfc_current_locus
;
1574 type
= sym
->result
->ts
.type
;
1576 type
= sym
->ts
.type
;
1578 if (sym
->attr
.result
&& type
== BT_UNKNOWN
&& sym
->ns
->proc_name
)
1579 type
= sym
->ns
->proc_name
->ts
.type
;
1581 if (type
!= BT_UNKNOWN
&& !(sym
->attr
.function
&& sym
->attr
.implicit_type
))
1583 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym
->name
,
1584 where
, gfc_basic_typename (type
));
1588 if (sym
->attr
.procedure
&& sym
->ts
.interface
)
1590 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1591 sym
->name
, where
, gfc_basic_typename (ts
->type
));
1595 flavor
= sym
->attr
.flavor
;
1597 if (flavor
== FL_PROGRAM
|| flavor
== FL_BLOCK_DATA
|| flavor
== FL_MODULE
1598 || flavor
== FL_LABEL
1599 || (flavor
== FL_PROCEDURE
&& sym
->attr
.subroutine
)
1600 || flavor
== FL_DERIVED
|| flavor
== FL_NAMELIST
)
1602 gfc_error ("Symbol '%s' at %L cannot have a type", sym
->name
, where
);
1611 /* Clears all attributes. */
1614 gfc_clear_attr (symbol_attribute
*attr
)
1616 memset (attr
, 0, sizeof (symbol_attribute
));
1620 /* Check for missing attributes in the new symbol. Currently does
1621 nothing, but it's not clear that it is unnecessary yet. */
1624 gfc_missing_attr (symbol_attribute
*attr ATTRIBUTE_UNUSED
,
1625 locus
*where ATTRIBUTE_UNUSED
)
1632 /* Copy an attribute to a symbol attribute, bit by bit. Some
1633 attributes have a lot of side-effects but cannot be present given
1634 where we are called from, so we ignore some bits. */
1637 gfc_copy_attr (symbol_attribute
*dest
, symbol_attribute
*src
, locus
*where
)
1639 int is_proc_lang_bind_spec
;
1641 /* In line with the other attributes, we only add bits but do not remove
1642 them; cf. also PR 41034. */
1643 dest
->ext_attr
|= src
->ext_attr
;
1645 if (src
->allocatable
&& gfc_add_allocatable (dest
, where
) == FAILURE
)
1648 if (src
->dimension
&& gfc_add_dimension (dest
, NULL
, where
) == FAILURE
)
1650 if (src
->optional
&& gfc_add_optional (dest
, where
) == FAILURE
)
1652 if (src
->pointer
&& gfc_add_pointer (dest
, where
) == FAILURE
)
1654 if (src
->is_protected
&& gfc_add_protected (dest
, NULL
, where
) == FAILURE
)
1656 if (src
->save
&& gfc_add_save (dest
, NULL
, where
) == FAILURE
)
1658 if (src
->value
&& gfc_add_value (dest
, NULL
, where
) == FAILURE
)
1660 if (src
->volatile_
&& gfc_add_volatile (dest
, NULL
, where
) == FAILURE
)
1662 if (src
->threadprivate
1663 && gfc_add_threadprivate (dest
, NULL
, where
) == FAILURE
)
1665 if (src
->target
&& gfc_add_target (dest
, where
) == FAILURE
)
1667 if (src
->dummy
&& gfc_add_dummy (dest
, NULL
, where
) == FAILURE
)
1669 if (src
->result
&& gfc_add_result (dest
, NULL
, where
) == FAILURE
)
1674 if (src
->in_namelist
&& gfc_add_in_namelist (dest
, NULL
, where
) == FAILURE
)
1677 if (src
->in_common
&& gfc_add_in_common (dest
, NULL
, where
) == FAILURE
)
1680 if (src
->generic
&& gfc_add_generic (dest
, NULL
, where
) == FAILURE
)
1682 if (src
->function
&& gfc_add_function (dest
, NULL
, where
) == FAILURE
)
1684 if (src
->subroutine
&& gfc_add_subroutine (dest
, NULL
, where
) == FAILURE
)
1687 if (src
->sequence
&& gfc_add_sequence (dest
, NULL
, where
) == FAILURE
)
1689 if (src
->elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1691 if (src
->pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1693 if (src
->recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1696 if (src
->flavor
!= FL_UNKNOWN
1697 && gfc_add_flavor (dest
, src
->flavor
, NULL
, where
) == FAILURE
)
1700 if (src
->intent
!= INTENT_UNKNOWN
1701 && gfc_add_intent (dest
, src
->intent
, where
) == FAILURE
)
1704 if (src
->access
!= ACCESS_UNKNOWN
1705 && gfc_add_access (dest
, src
->access
, NULL
, where
) == FAILURE
)
1708 if (gfc_missing_attr (dest
, where
) == FAILURE
)
1711 if (src
->cray_pointer
&& gfc_add_cray_pointer (dest
, where
) == FAILURE
)
1713 if (src
->cray_pointee
&& gfc_add_cray_pointee (dest
, where
) == FAILURE
)
1716 is_proc_lang_bind_spec
= (src
->flavor
== FL_PROCEDURE
? 1 : 0);
1718 && gfc_add_is_bind_c (dest
, NULL
, where
, is_proc_lang_bind_spec
)
1722 if (src
->is_c_interop
)
1723 dest
->is_c_interop
= 1;
1727 if (src
->external
&& gfc_add_external (dest
, where
) == FAILURE
)
1729 if (src
->intrinsic
&& gfc_add_intrinsic (dest
, where
) == FAILURE
)
1731 if (src
->proc_pointer
)
1732 dest
->proc_pointer
= 1;
1741 /************** Component name management ************/
1743 /* Component names of a derived type form their own little namespaces
1744 that are separate from all other spaces. The space is composed of
1745 a singly linked list of gfc_component structures whose head is
1746 located in the parent symbol. */
1749 /* Add a component name to a symbol. The call fails if the name is
1750 already present. On success, the component pointer is modified to
1751 point to the additional component structure. */
1754 gfc_add_component (gfc_symbol
*sym
, const char *name
,
1755 gfc_component
**component
)
1757 gfc_component
*p
, *tail
;
1761 for (p
= sym
->components
; p
; p
= p
->next
)
1763 if (strcmp (p
->name
, name
) == 0)
1765 gfc_error ("Component '%s' at %C already declared at %L",
1773 if (sym
->attr
.extension
1774 && gfc_find_component (sym
->components
->ts
.u
.derived
, name
, true, true))
1776 gfc_error ("Component '%s' at %C already in the parent type "
1777 "at %L", name
, &sym
->components
->ts
.u
.derived
->declared_at
);
1781 /* Allocate a new component. */
1782 p
= gfc_get_component ();
1785 sym
->components
= p
;
1789 p
->name
= gfc_get_string (name
);
1790 p
->loc
= gfc_current_locus
;
1791 p
->ts
.type
= BT_UNKNOWN
;
1798 /* Recursive function to switch derived types of all symbol in a
1802 switch_types (gfc_symtree
*st
, gfc_symbol
*from
, gfc_symbol
*to
)
1810 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
== from
)
1811 sym
->ts
.u
.derived
= to
;
1813 switch_types (st
->left
, from
, to
);
1814 switch_types (st
->right
, from
, to
);
1818 /* This subroutine is called when a derived type is used in order to
1819 make the final determination about which version to use. The
1820 standard requires that a type be defined before it is 'used', but
1821 such types can appear in IMPLICIT statements before the actual
1822 definition. 'Using' in this context means declaring a variable to
1823 be that type or using the type constructor.
1825 If a type is used and the components haven't been defined, then we
1826 have to have a derived type in a parent unit. We find the node in
1827 the other namespace and point the symtree node in this namespace to
1828 that node. Further reference to this name point to the correct
1829 node. If we can't find the node in a parent namespace, then we have
1832 This subroutine takes a pointer to a symbol node and returns a
1833 pointer to the translated node or NULL for an error. Usually there
1834 is no translation and we return the node we were passed. */
1837 gfc_use_derived (gfc_symbol
*sym
)
1844 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
1845 return sym
; /* Already defined. */
1847 if (sym
->ns
->parent
== NULL
)
1850 if (gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
))
1852 gfc_error ("Symbol '%s' at %C is ambiguous", sym
->name
);
1856 if (s
== NULL
|| s
->attr
.flavor
!= FL_DERIVED
)
1859 /* Get rid of symbol sym, translating all references to s. */
1860 for (i
= 0; i
< GFC_LETTERS
; i
++)
1862 t
= &sym
->ns
->default_type
[i
];
1863 if (t
->u
.derived
== sym
)
1867 st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1872 /* Unlink from list of modified symbols. */
1873 gfc_commit_symbol (sym
);
1875 switch_types (sym
->ns
->sym_root
, sym
, s
);
1877 /* TODO: Also have to replace sym -> s in other lists like
1878 namelists, common lists and interface lists. */
1879 gfc_free_symbol (sym
);
1884 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1890 /* Given a derived type node and a component name, try to locate the
1891 component structure. Returns the NULL pointer if the component is
1892 not found or the components are private. If noaccess is set, no access
1896 gfc_find_component (gfc_symbol
*sym
, const char *name
,
1897 bool noaccess
, bool silent
)
1904 sym
= gfc_use_derived (sym
);
1909 for (p
= sym
->components
; p
; p
= p
->next
)
1910 if (strcmp (p
->name
, name
) == 0)
1914 && sym
->attr
.extension
1915 && sym
->components
->ts
.type
== BT_DERIVED
)
1917 p
= gfc_find_component (sym
->components
->ts
.u
.derived
, name
,
1919 /* Do not overwrite the error. */
1924 if (p
== NULL
&& !silent
)
1925 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1928 else if (sym
->attr
.use_assoc
&& !noaccess
)
1930 if (p
->attr
.access
== ACCESS_PRIVATE
)
1933 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1938 /* If there were components given and all components are private, error
1939 out at this place. */
1940 if (p
->attr
.access
!= ACCESS_PUBLIC
&& sym
->component_access
== ACCESS_PRIVATE
)
1943 gfc_error ("All components of '%s' are PRIVATE in structure"
1944 " constructor at %C", sym
->name
);
1953 /* Given a symbol, free all of the component structures and everything
1957 free_components (gfc_component
*p
)
1965 gfc_free_array_spec (p
->as
);
1966 gfc_free_expr (p
->initializer
);
1973 /******************** Statement label management ********************/
1975 /* Comparison function for statement labels, used for managing the
1979 compare_st_labels (void *a1
, void *b1
)
1981 int a
= ((gfc_st_label
*) a1
)->value
;
1982 int b
= ((gfc_st_label
*) b1
)->value
;
1988 /* Free a single gfc_st_label structure, making sure the tree is not
1989 messed up. This function is called only when some parse error
1993 gfc_free_st_label (gfc_st_label
*label
)
1999 gfc_delete_bbt (&gfc_current_ns
->st_labels
, label
, compare_st_labels
);
2001 if (label
->format
!= NULL
)
2002 gfc_free_expr (label
->format
);
2008 /* Free a whole tree of gfc_st_label structures. */
2011 free_st_labels (gfc_st_label
*label
)
2017 free_st_labels (label
->left
);
2018 free_st_labels (label
->right
);
2020 if (label
->format
!= NULL
)
2021 gfc_free_expr (label
->format
);
2026 /* Given a label number, search for and return a pointer to the label
2027 structure, creating it if it does not exist. */
2030 gfc_get_st_label (int labelno
)
2035 /* Find the namespace of the scoping unit:
2036 If we're in a BLOCK construct, jump to the parent namespace. */
2037 ns
= gfc_current_ns
;
2038 while (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
)
2041 /* First see if the label is already in this namespace. */
2045 if (lp
->value
== labelno
)
2048 if (lp
->value
< labelno
)
2054 lp
= XCNEW (gfc_st_label
);
2056 lp
->value
= labelno
;
2057 lp
->defined
= ST_LABEL_UNKNOWN
;
2058 lp
->referenced
= ST_LABEL_UNKNOWN
;
2060 gfc_insert_bbt (&ns
->st_labels
, lp
, compare_st_labels
);
2066 /* Called when a statement with a statement label is about to be
2067 accepted. We add the label to the list of the current namespace,
2068 making sure it hasn't been defined previously and referenced
2072 gfc_define_st_label (gfc_st_label
*lp
, gfc_sl_type type
, locus
*label_locus
)
2076 labelno
= lp
->value
;
2078 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2079 gfc_error ("Duplicate statement label %d at %L and %L", labelno
,
2080 &lp
->where
, label_locus
);
2083 lp
->where
= *label_locus
;
2087 case ST_LABEL_FORMAT
:
2088 if (lp
->referenced
== ST_LABEL_TARGET
)
2089 gfc_error ("Label %d at %C already referenced as branch target",
2092 lp
->defined
= ST_LABEL_FORMAT
;
2096 case ST_LABEL_TARGET
:
2097 if (lp
->referenced
== ST_LABEL_FORMAT
)
2098 gfc_error ("Label %d at %C already referenced as a format label",
2101 lp
->defined
= ST_LABEL_TARGET
;
2106 lp
->defined
= ST_LABEL_BAD_TARGET
;
2107 lp
->referenced
= ST_LABEL_BAD_TARGET
;
2113 /* Reference a label. Given a label and its type, see if that
2114 reference is consistent with what is known about that label,
2115 updating the unknown state. Returns FAILURE if something goes
2119 gfc_reference_st_label (gfc_st_label
*lp
, gfc_sl_type type
)
2121 gfc_sl_type label_type
;
2128 labelno
= lp
->value
;
2130 if (lp
->defined
!= ST_LABEL_UNKNOWN
)
2131 label_type
= lp
->defined
;
2134 label_type
= lp
->referenced
;
2135 lp
->where
= gfc_current_locus
;
2138 if (label_type
== ST_LABEL_FORMAT
&& type
== ST_LABEL_TARGET
)
2140 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno
);
2145 if ((label_type
== ST_LABEL_TARGET
|| label_type
== ST_LABEL_BAD_TARGET
)
2146 && type
== ST_LABEL_FORMAT
)
2148 gfc_error ("Label %d at %C previously used as branch target", labelno
);
2153 lp
->referenced
= type
;
2161 /*******A helper function for creating new expressions*************/
2165 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
2168 lval
= gfc_get_expr ();
2169 lval
->expr_type
= EXPR_VARIABLE
;
2170 lval
->where
= sym
->declared_at
;
2172 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
2174 /* It will always be a full array. */
2175 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
2178 lval
->ref
= gfc_get_ref ();
2179 lval
->ref
->type
= REF_ARRAY
;
2180 lval
->ref
->u
.ar
.type
= AR_FULL
;
2181 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
2182 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
2183 lval
->ref
->u
.ar
.as
= sym
->as
;
2190 /************** Symbol table management subroutines ****************/
2192 /* Basic details: Fortran 95 requires a potentially unlimited number
2193 of distinct namespaces when compiling a program unit. This case
2194 occurs during a compilation of internal subprograms because all of
2195 the internal subprograms must be read before we can start
2196 generating code for the host.
2198 Given the tricky nature of the Fortran grammar, we must be able to
2199 undo changes made to a symbol table if the current interpretation
2200 of a statement is found to be incorrect. Whenever a symbol is
2201 looked up, we make a copy of it and link to it. All of these
2202 symbols are kept in a singly linked list so that we can commit or
2203 undo the changes at a later time.
2205 A symtree may point to a symbol node outside of its namespace. In
2206 this case, that symbol has been used as a host associated variable
2207 at some previous time. */
2209 /* Allocate a new namespace structure. Copies the implicit types from
2210 PARENT if PARENT_TYPES is set. */
2213 gfc_get_namespace (gfc_namespace
*parent
, int parent_types
)
2220 ns
= XCNEW (gfc_namespace
);
2221 ns
->sym_root
= NULL
;
2222 ns
->uop_root
= NULL
;
2223 ns
->tb_sym_root
= NULL
;
2224 ns
->finalizers
= NULL
;
2225 ns
->default_access
= ACCESS_UNKNOWN
;
2226 ns
->parent
= parent
;
2228 for (in
= GFC_INTRINSIC_BEGIN
; in
!= GFC_INTRINSIC_END
; in
++)
2230 ns
->operator_access
[in
] = ACCESS_UNKNOWN
;
2231 ns
->tb_op
[in
] = NULL
;
2234 /* Initialize default implicit types. */
2235 for (i
= 'a'; i
<= 'z'; i
++)
2237 ns
->set_flag
[i
- 'a'] = 0;
2238 ts
= &ns
->default_type
[i
- 'a'];
2240 if (parent_types
&& ns
->parent
!= NULL
)
2242 /* Copy parent settings. */
2243 *ts
= ns
->parent
->default_type
[i
- 'a'];
2247 if (gfc_option
.flag_implicit_none
!= 0)
2253 if ('i' <= i
&& i
<= 'n')
2255 ts
->type
= BT_INTEGER
;
2256 ts
->kind
= gfc_default_integer_kind
;
2261 ts
->kind
= gfc_default_real_kind
;
2271 /* Comparison function for symtree nodes. */
2274 compare_symtree (void *_st1
, void *_st2
)
2276 gfc_symtree
*st1
, *st2
;
2278 st1
= (gfc_symtree
*) _st1
;
2279 st2
= (gfc_symtree
*) _st2
;
2281 return strcmp (st1
->name
, st2
->name
);
2285 /* Allocate a new symtree node and associate it with the new symbol. */
2288 gfc_new_symtree (gfc_symtree
**root
, const char *name
)
2292 st
= XCNEW (gfc_symtree
);
2293 st
->name
= gfc_get_string (name
);
2295 gfc_insert_bbt (root
, st
, compare_symtree
);
2300 /* Delete a symbol from the tree. Does not free the symbol itself! */
2303 gfc_delete_symtree (gfc_symtree
**root
, const char *name
)
2305 gfc_symtree st
, *st0
;
2307 st0
= gfc_find_symtree (*root
, name
);
2309 st
.name
= gfc_get_string (name
);
2310 gfc_delete_bbt (root
, &st
, compare_symtree
);
2316 /* Given a root symtree node and a name, try to find the symbol within
2317 the namespace. Returns NULL if the symbol is not found. */
2320 gfc_find_symtree (gfc_symtree
*st
, const char *name
)
2326 c
= strcmp (name
, st
->name
);
2330 st
= (c
< 0) ? st
->left
: st
->right
;
2337 /* Return a symtree node with a name that is guaranteed to be unique
2338 within the namespace and corresponds to an illegal fortran name. */
2341 gfc_get_unique_symtree (gfc_namespace
*ns
)
2343 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2344 static int serial
= 0;
2346 sprintf (name
, "@%d", serial
++);
2347 return gfc_new_symtree (&ns
->sym_root
, name
);
2351 /* Given a name find a user operator node, creating it if it doesn't
2352 exist. These are much simpler than symbols because they can't be
2353 ambiguous with one another. */
2356 gfc_get_uop (const char *name
)
2361 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
2365 st
= gfc_new_symtree (&gfc_current_ns
->uop_root
, name
);
2367 uop
= st
->n
.uop
= XCNEW (gfc_user_op
);
2368 uop
->name
= gfc_get_string (name
);
2369 uop
->access
= ACCESS_UNKNOWN
;
2370 uop
->ns
= gfc_current_ns
;
2376 /* Given a name find the user operator node. Returns NULL if it does
2380 gfc_find_uop (const char *name
, gfc_namespace
*ns
)
2385 ns
= gfc_current_ns
;
2387 st
= gfc_find_symtree (ns
->uop_root
, name
);
2388 return (st
== NULL
) ? NULL
: st
->n
.uop
;
2392 /* Remove a gfc_symbol structure and everything it points to. */
2395 gfc_free_symbol (gfc_symbol
*sym
)
2401 gfc_free_array_spec (sym
->as
);
2403 free_components (sym
->components
);
2405 gfc_free_expr (sym
->value
);
2407 gfc_free_namelist (sym
->namelist
);
2409 gfc_free_namespace (sym
->formal_ns
);
2411 if (!sym
->attr
.generic_copy
)
2412 gfc_free_interface (sym
->generic
);
2414 gfc_free_formal_arglist (sym
->formal
);
2416 gfc_free_namespace (sym
->f2k_derived
);
2422 /* Allocate and initialize a new symbol node. */
2425 gfc_new_symbol (const char *name
, gfc_namespace
*ns
)
2429 p
= XCNEW (gfc_symbol
);
2431 gfc_clear_ts (&p
->ts
);
2432 gfc_clear_attr (&p
->attr
);
2435 p
->declared_at
= gfc_current_locus
;
2437 if (strlen (name
) > GFC_MAX_SYMBOL_LEN
)
2438 gfc_internal_error ("new_symbol(): Symbol name too long");
2440 p
->name
= gfc_get_string (name
);
2442 /* Make sure flags for symbol being C bound are clear initially. */
2443 p
->attr
.is_bind_c
= 0;
2444 p
->attr
.is_iso_c
= 0;
2445 /* Make sure the binding label field has a Nul char to start. */
2446 p
->binding_label
[0] = '\0';
2448 /* Clear the ptrs we may need. */
2449 p
->common_block
= NULL
;
2450 p
->f2k_derived
= NULL
;
2456 /* Generate an error if a symbol is ambiguous. */
2459 ambiguous_symbol (const char *name
, gfc_symtree
*st
)
2462 if (st
->n
.sym
->module
)
2463 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2464 "from module '%s'", name
, st
->n
.sym
->name
, st
->n
.sym
->module
);
2466 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2467 "from current program unit", name
, st
->n
.sym
->name
);
2471 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2472 selector on the stack. If yes, replace it by the corresponding temporary. */
2475 select_type_insert_tmp (gfc_symtree
**st
)
2477 gfc_select_type_stack
*stack
= select_type_stack
;
2478 for (; stack
; stack
= stack
->prev
)
2479 if ((*st
)->n
.sym
== stack
->selector
)
2484 /* Search for a symtree starting in the current namespace, resorting to
2485 any parent namespaces if requested by a nonzero parent_flag.
2486 Returns nonzero if the name is ambiguous. */
2489 gfc_find_sym_tree (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2490 gfc_symtree
**result
)
2495 ns
= gfc_current_ns
;
2499 st
= gfc_find_symtree (ns
->sym_root
, name
);
2502 select_type_insert_tmp (&st
);
2505 /* Ambiguous generic interfaces are permitted, as long
2506 as the specific interfaces are different. */
2507 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2509 ambiguous_symbol (name
, st
);
2528 /* Same, but returns the symbol instead. */
2531 gfc_find_symbol (const char *name
, gfc_namespace
*ns
, int parent_flag
,
2532 gfc_symbol
**result
)
2537 i
= gfc_find_sym_tree (name
, ns
, parent_flag
, &st
);
2542 *result
= st
->n
.sym
;
2548 /* Save symbol with the information necessary to back it out. */
2551 save_symbol_data (gfc_symbol
*sym
)
2554 if (sym
->gfc_new
|| sym
->old_symbol
!= NULL
)
2557 sym
->old_symbol
= XCNEW (gfc_symbol
);
2558 *(sym
->old_symbol
) = *sym
;
2560 sym
->tlink
= changed_syms
;
2565 /* Given a name, find a symbol, or create it if it does not exist yet
2566 in the current namespace. If the symbol is found we make sure that
2569 The integer return code indicates
2571 1 The symbol name was ambiguous
2572 2 The name meant to be established was already host associated.
2574 So if the return value is nonzero, then an error was issued. */
2577 gfc_get_sym_tree (const char *name
, gfc_namespace
*ns
, gfc_symtree
**result
,
2578 bool allow_subroutine
)
2583 /* This doesn't usually happen during resolution. */
2585 ns
= gfc_current_ns
;
2587 /* Try to find the symbol in ns. */
2588 st
= gfc_find_symtree (ns
->sym_root
, name
);
2592 /* If not there, create a new symbol. */
2593 p
= gfc_new_symbol (name
, ns
);
2595 /* Add to the list of tentative symbols. */
2596 p
->old_symbol
= NULL
;
2597 p
->tlink
= changed_syms
;
2602 st
= gfc_new_symtree (&ns
->sym_root
, name
);
2609 /* Make sure the existing symbol is OK. Ambiguous
2610 generic interfaces are permitted, as long as the
2611 specific interfaces are different. */
2612 if (st
->ambiguous
&& !st
->n
.sym
->attr
.generic
)
2614 ambiguous_symbol (name
, st
);
2619 if (p
->ns
!= ns
&& (!p
->attr
.function
|| ns
->proc_name
!= p
)
2620 && !(allow_subroutine
&& p
->attr
.subroutine
)
2621 && !(ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2622 && (ns
->has_import_set
|| p
->attr
.imported
)))
2624 /* Symbol is from another namespace. */
2625 gfc_error ("Symbol '%s' at %C has already been host associated",
2632 /* Copy in case this symbol is changed. */
2633 save_symbol_data (p
);
2642 gfc_get_symbol (const char *name
, gfc_namespace
*ns
, gfc_symbol
**result
)
2647 i
= gfc_get_sym_tree (name
, ns
, &st
, false);
2652 *result
= st
->n
.sym
;
2659 /* Subroutine that searches for a symbol, creating it if it doesn't
2660 exist, but tries to host-associate the symbol if possible. */
2663 gfc_get_ha_sym_tree (const char *name
, gfc_symtree
**result
)
2668 i
= gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
2672 save_symbol_data (st
->n
.sym
);
2677 if (gfc_current_ns
->parent
!= NULL
)
2679 i
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 1, &st
);
2690 return gfc_get_sym_tree (name
, gfc_current_ns
, result
, false);
2695 gfc_get_ha_symbol (const char *name
, gfc_symbol
**result
)
2700 i
= gfc_get_ha_sym_tree (name
, &st
);
2703 *result
= st
->n
.sym
;
2710 /* Return true if both symbols could refer to the same data object. Does
2711 not take account of aliasing due to equivalence statements. */
2714 gfc_symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
)
2716 /* Aliasing isn't possible if the symbols have different base types. */
2717 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
2720 /* Pointers can point to other pointers, target objects and allocatable
2721 objects. Two allocatable objects cannot share the same storage. */
2722 if (lsym
->attr
.pointer
2723 && (rsym
->attr
.pointer
|| rsym
->attr
.allocatable
|| rsym
->attr
.target
))
2725 if (lsym
->attr
.target
&& rsym
->attr
.pointer
)
2727 if (lsym
->attr
.allocatable
&& rsym
->attr
.pointer
)
2734 /* Undoes all the changes made to symbols in the current statement.
2735 This subroutine is made simpler due to the fact that attributes are
2736 never removed once added. */
2739 gfc_undo_symbols (void)
2741 gfc_symbol
*p
, *q
, *old
;
2742 tentative_tbp
*tbp
, *tbq
;
2744 for (p
= changed_syms
; p
; p
= q
)
2750 /* Symbol was new. */
2751 if (p
->attr
.in_common
&& p
->common_block
&& p
->common_block
->head
)
2753 /* If the symbol was added to any common block, it
2754 needs to be removed to stop the resolver looking
2755 for a (possibly) dead symbol. */
2757 if (p
->common_block
->head
== p
)
2758 p
->common_block
->head
= p
->common_next
;
2761 gfc_symbol
*cparent
, *csym
;
2763 cparent
= p
->common_block
->head
;
2764 csym
= cparent
->common_next
;
2769 csym
= csym
->common_next
;
2772 gcc_assert(cparent
->common_next
== p
);
2774 cparent
->common_next
= csym
->common_next
;
2778 gfc_delete_symtree (&p
->ns
->sym_root
, p
->name
);
2782 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2784 gfc_free_symbol (p
);
2788 /* Restore previous state of symbol. Just copy simple stuff. */
2790 old
= p
->old_symbol
;
2792 p
->ts
.type
= old
->ts
.type
;
2793 p
->ts
.kind
= old
->ts
.kind
;
2795 p
->attr
= old
->attr
;
2797 if (p
->value
!= old
->value
)
2799 gfc_free_expr (old
->value
);
2803 if (p
->as
!= old
->as
)
2806 gfc_free_array_spec (p
->as
);
2810 p
->generic
= old
->generic
;
2811 p
->component_access
= old
->component_access
;
2813 if (p
->namelist
!= NULL
&& old
->namelist
== NULL
)
2815 gfc_free_namelist (p
->namelist
);
2820 if (p
->namelist_tail
!= old
->namelist_tail
)
2822 gfc_free_namelist (old
->namelist_tail
);
2823 old
->namelist_tail
->next
= NULL
;
2827 p
->namelist_tail
= old
->namelist_tail
;
2829 if (p
->formal
!= old
->formal
)
2831 gfc_free_formal_arglist (p
->formal
);
2832 p
->formal
= old
->formal
;
2835 gfc_free (p
->old_symbol
);
2836 p
->old_symbol
= NULL
;
2840 changed_syms
= NULL
;
2842 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2845 /* Procedure is already marked `error' by default. */
2848 tentative_tbp_list
= NULL
;
2852 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2853 components of old_symbol that might need deallocation are the "allocatables"
2854 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2855 namelist_tail. In case these differ between old_symbol and sym, it's just
2856 because sym->namelist has gotten a few more items. */
2859 free_old_symbol (gfc_symbol
*sym
)
2862 if (sym
->old_symbol
== NULL
)
2865 if (sym
->old_symbol
->as
!= sym
->as
)
2866 gfc_free_array_spec (sym
->old_symbol
->as
);
2868 if (sym
->old_symbol
->value
!= sym
->value
)
2869 gfc_free_expr (sym
->old_symbol
->value
);
2871 if (sym
->old_symbol
->formal
!= sym
->formal
)
2872 gfc_free_formal_arglist (sym
->old_symbol
->formal
);
2874 gfc_free (sym
->old_symbol
);
2875 sym
->old_symbol
= NULL
;
2879 /* Makes the changes made in the current statement permanent-- gets
2880 rid of undo information. */
2883 gfc_commit_symbols (void)
2886 tentative_tbp
*tbp
, *tbq
;
2888 for (p
= changed_syms
; p
; p
= q
)
2894 free_old_symbol (p
);
2896 changed_syms
= NULL
;
2898 for (tbp
= tentative_tbp_list
; tbp
; tbp
= tbq
)
2901 tbp
->proc
->error
= 0;
2904 tentative_tbp_list
= NULL
;
2908 /* Makes the changes made in one symbol permanent -- gets rid of undo
2912 gfc_commit_symbol (gfc_symbol
*sym
)
2916 if (changed_syms
== sym
)
2917 changed_syms
= sym
->tlink
;
2920 for (p
= changed_syms
; p
; p
= p
->tlink
)
2921 if (p
->tlink
== sym
)
2923 p
->tlink
= sym
->tlink
;
2932 free_old_symbol (sym
);
2936 /* Recursively free trees containing type-bound procedures. */
2939 free_tb_tree (gfc_symtree
*t
)
2944 free_tb_tree (t
->left
);
2945 free_tb_tree (t
->right
);
2947 /* TODO: Free type-bound procedure structs themselves; probably needs some
2948 sort of ref-counting mechanism. */
2954 /* Recursive function that deletes an entire tree and all the common
2955 head structures it points to. */
2958 free_common_tree (gfc_symtree
* common_tree
)
2960 if (common_tree
== NULL
)
2963 free_common_tree (common_tree
->left
);
2964 free_common_tree (common_tree
->right
);
2966 gfc_free (common_tree
);
2970 /* Recursive function that deletes an entire tree and all the user
2971 operator nodes that it contains. */
2974 free_uop_tree (gfc_symtree
*uop_tree
)
2976 if (uop_tree
== NULL
)
2979 free_uop_tree (uop_tree
->left
);
2980 free_uop_tree (uop_tree
->right
);
2982 gfc_free_interface (uop_tree
->n
.uop
->op
);
2983 gfc_free (uop_tree
->n
.uop
);
2984 gfc_free (uop_tree
);
2988 /* Recursive function that deletes an entire tree and all the symbols
2989 that it contains. */
2992 free_sym_tree (gfc_symtree
*sym_tree
)
2997 if (sym_tree
== NULL
)
3000 free_sym_tree (sym_tree
->left
);
3001 free_sym_tree (sym_tree
->right
);
3003 sym
= sym_tree
->n
.sym
;
3007 gfc_internal_error ("free_sym_tree(): Negative refs");
3009 if (sym
->formal_ns
!= NULL
&& sym
->refs
== 1)
3011 /* As formal_ns contains a reference to sym, delete formal_ns just
3012 before the deletion of sym. */
3013 ns
= sym
->formal_ns
;
3014 sym
->formal_ns
= NULL
;
3015 gfc_free_namespace (ns
);
3017 else if (sym
->refs
== 0)
3019 /* Go ahead and delete the symbol. */
3020 gfc_free_symbol (sym
);
3023 gfc_free (sym_tree
);
3027 /* Free the derived type list. */
3030 gfc_free_dt_list (void)
3032 gfc_dt_list
*dt
, *n
;
3034 for (dt
= gfc_derived_types
; dt
; dt
= n
)
3040 gfc_derived_types
= NULL
;
3044 /* Free the gfc_equiv_info's. */
3047 gfc_free_equiv_infos (gfc_equiv_info
*s
)
3051 gfc_free_equiv_infos (s
->next
);
3056 /* Free the gfc_equiv_lists. */
3059 gfc_free_equiv_lists (gfc_equiv_list
*l
)
3063 gfc_free_equiv_lists (l
->next
);
3064 gfc_free_equiv_infos (l
->equiv
);
3069 /* Free a finalizer procedure list. */
3072 gfc_free_finalizer (gfc_finalizer
* el
)
3078 --el
->proc_sym
->refs
;
3079 if (!el
->proc_sym
->refs
)
3080 gfc_free_symbol (el
->proc_sym
);
3088 gfc_free_finalizer_list (gfc_finalizer
* list
)
3092 gfc_finalizer
* current
= list
;
3094 gfc_free_finalizer (current
);
3099 /* Create a new gfc_charlen structure and add it to a namespace.
3100 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3103 gfc_new_charlen (gfc_namespace
*ns
, gfc_charlen
*old_cl
)
3106 cl
= gfc_get_charlen ();
3108 /* Put into namespace. */
3109 cl
->next
= ns
->cl_list
;
3115 cl
->length
= gfc_copy_expr (old_cl
->length
);
3116 cl
->length_from_typespec
= old_cl
->length_from_typespec
;
3117 cl
->backend_decl
= old_cl
->backend_decl
;
3118 cl
->passed_length
= old_cl
->passed_length
;
3119 cl
->resolved
= old_cl
->resolved
;
3126 /* Free the charlen list from cl to end (end is not freed).
3127 Free the whole list if end is NULL. */
3129 void gfc_free_charlen (gfc_charlen
*cl
, gfc_charlen
*end
)
3133 for (; cl
!= end
; cl
= cl2
)
3138 gfc_free_expr (cl
->length
);
3144 /* Free a namespace structure and everything below it. Interface
3145 lists associated with intrinsic operators are not freed. These are
3146 taken care of when a specific name is freed. */
3149 gfc_free_namespace (gfc_namespace
*ns
)
3151 gfc_namespace
*p
, *q
;
3160 gcc_assert (ns
->refs
== 0);
3162 gfc_free_statements (ns
->code
);
3164 free_sym_tree (ns
->sym_root
);
3165 free_uop_tree (ns
->uop_root
);
3166 free_common_tree (ns
->common_root
);
3167 free_tb_tree (ns
->tb_sym_root
);
3168 free_tb_tree (ns
->tb_uop_root
);
3169 gfc_free_finalizer_list (ns
->finalizers
);
3170 gfc_free_charlen (ns
->cl_list
, NULL
);
3171 free_st_labels (ns
->st_labels
);
3173 gfc_free_equiv (ns
->equiv
);
3174 gfc_free_equiv_lists (ns
->equiv_lists
);
3175 gfc_free_use_stmts (ns
->use_stmts
);
3177 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3178 gfc_free_interface (ns
->op
[i
]);
3180 gfc_free_data (ns
->data
);
3184 /* Recursively free any contained namespaces. */
3189 gfc_free_namespace (q
);
3195 gfc_symbol_init_2 (void)
3198 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3203 gfc_symbol_done_2 (void)
3206 gfc_free_namespace (gfc_current_ns
);
3207 gfc_current_ns
= NULL
;
3208 gfc_free_dt_list ();
3212 /* Clear mark bits from symbol nodes associated with a symtree node. */
3215 clear_sym_mark (gfc_symtree
*st
)
3218 st
->n
.sym
->mark
= 0;
3222 /* Recursively traverse the symtree nodes. */
3225 gfc_traverse_symtree (gfc_symtree
*st
, void (*func
) (gfc_symtree
*))
3230 gfc_traverse_symtree (st
->left
, func
);
3232 gfc_traverse_symtree (st
->right
, func
);
3236 /* Recursive namespace traversal function. */
3239 traverse_ns (gfc_symtree
*st
, void (*func
) (gfc_symbol
*))
3245 traverse_ns (st
->left
, func
);
3247 if (st
->n
.sym
->mark
== 0)
3248 (*func
) (st
->n
.sym
);
3249 st
->n
.sym
->mark
= 1;
3251 traverse_ns (st
->right
, func
);
3255 /* Call a given function for all symbols in the namespace. We take
3256 care that each gfc_symbol node is called exactly once. */
3259 gfc_traverse_ns (gfc_namespace
*ns
, void (*func
) (gfc_symbol
*))
3262 gfc_traverse_symtree (ns
->sym_root
, clear_sym_mark
);
3264 traverse_ns (ns
->sym_root
, func
);
3268 /* Return TRUE when name is the name of an intrinsic type. */
3271 gfc_is_intrinsic_typename (const char *name
)
3273 if (strcmp (name
, "integer") == 0
3274 || strcmp (name
, "real") == 0
3275 || strcmp (name
, "character") == 0
3276 || strcmp (name
, "logical") == 0
3277 || strcmp (name
, "complex") == 0
3278 || strcmp (name
, "doubleprecision") == 0
3279 || strcmp (name
, "doublecomplex") == 0)
3286 /* Return TRUE if the symbol is an automatic variable. */
3289 gfc_is_var_automatic (gfc_symbol
*sym
)
3291 /* Pointer and allocatable variables are never automatic. */
3292 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3294 /* Check for arrays with non-constant size. */
3295 if (sym
->attr
.dimension
&& sym
->as
3296 && !gfc_is_compile_time_shape (sym
->as
))
3298 /* Check for non-constant length character variables. */
3299 if (sym
->ts
.type
== BT_CHARACTER
3301 && !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
))
3306 /* Given a symbol, mark it as SAVEd if it is allowed. */
3309 save_symbol (gfc_symbol
*sym
)
3312 if (sym
->attr
.use_assoc
)
3315 if (sym
->attr
.in_common
3318 || sym
->attr
.flavor
!= FL_VARIABLE
)
3320 /* Automatic objects are not saved. */
3321 if (gfc_is_var_automatic (sym
))
3323 gfc_add_save (&sym
->attr
, sym
->name
, &sym
->declared_at
);
3327 /* Mark those symbols which can be SAVEd as such. */
3330 gfc_save_all (gfc_namespace
*ns
)
3332 gfc_traverse_ns (ns
, save_symbol
);
3337 /* Make sure that no changes to symbols are pending. */
3340 gfc_symbol_state(void) {
3342 if (changed_syms
!= NULL
)
3343 gfc_internal_error("Symbol changes still pending!");
3348 /************** Global symbol handling ************/
3351 /* Search a tree for the global symbol. */
3354 gfc_find_gsymbol (gfc_gsymbol
*symbol
, const char *name
)
3363 c
= strcmp (name
, symbol
->name
);
3367 symbol
= (c
< 0) ? symbol
->left
: symbol
->right
;
3374 /* Compare two global symbols. Used for managing the BB tree. */
3377 gsym_compare (void *_s1
, void *_s2
)
3379 gfc_gsymbol
*s1
, *s2
;
3381 s1
= (gfc_gsymbol
*) _s1
;
3382 s2
= (gfc_gsymbol
*) _s2
;
3383 return strcmp (s1
->name
, s2
->name
);
3387 /* Get a global symbol, creating it if it doesn't exist. */
3390 gfc_get_gsymbol (const char *name
)
3394 s
= gfc_find_gsymbol (gfc_gsym_root
, name
);
3398 s
= XCNEW (gfc_gsymbol
);
3399 s
->type
= GSYM_UNKNOWN
;
3400 s
->name
= gfc_get_string (name
);
3402 gfc_insert_bbt (&gfc_gsym_root
, s
, gsym_compare
);
3409 get_iso_c_binding_dt (int sym_id
)
3411 gfc_dt_list
*dt_list
;
3413 dt_list
= gfc_derived_types
;
3415 /* Loop through the derived types in the name list, searching for
3416 the desired symbol from iso_c_binding. Search the parent namespaces
3417 if necessary and requested to (parent_flag). */
3418 while (dt_list
!= NULL
)
3420 if (dt_list
->derived
->from_intmod
!= INTMOD_NONE
3421 && dt_list
->derived
->intmod_sym_id
== sym_id
)
3422 return dt_list
->derived
;
3424 dt_list
= dt_list
->next
;
3431 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3432 with C. This is necessary for any derived type that is BIND(C) and for
3433 derived types that are parameters to functions that are BIND(C). All
3434 fields of the derived type are required to be interoperable, and are tested
3435 for such. If an error occurs, the errors are reported here, allowing for
3436 multiple errors to be handled for a single derived type. */
3439 verify_bind_c_derived_type (gfc_symbol
*derived_sym
)
3441 gfc_component
*curr_comp
= NULL
;
3442 gfc_try is_c_interop
= FAILURE
;
3443 gfc_try retval
= SUCCESS
;
3445 if (derived_sym
== NULL
)
3446 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3447 "unexpectedly NULL");
3449 /* If we've already looked at this derived symbol, do not look at it again
3450 so we don't repeat warnings/errors. */
3451 if (derived_sym
->ts
.is_c_interop
)
3454 /* The derived type must have the BIND attribute to be interoperable
3455 J3/04-007, Section 15.2.3. */
3456 if (derived_sym
->attr
.is_bind_c
!= 1)
3458 derived_sym
->ts
.is_c_interop
= 0;
3459 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3460 "attribute to be C interoperable", derived_sym
->name
,
3461 &(derived_sym
->declared_at
));
3465 curr_comp
= derived_sym
->components
;
3467 /* TODO: is this really an error? */
3468 if (curr_comp
== NULL
)
3470 gfc_error ("Derived type '%s' at %L is empty",
3471 derived_sym
->name
, &(derived_sym
->declared_at
));
3475 /* Initialize the derived type as being C interoperable.
3476 If we find an error in the components, this will be set false. */
3477 derived_sym
->ts
.is_c_interop
= 1;
3479 /* Loop through the list of components to verify that the kind of
3480 each is a C interoperable type. */
3483 /* The components cannot be pointers (fortran sense).
3484 J3/04-007, Section 15.2.3, C1505. */
3485 if (curr_comp
->attr
.pointer
!= 0)
3487 gfc_error ("Component '%s' at %L cannot have the "
3488 "POINTER attribute because it is a member "
3489 "of the BIND(C) derived type '%s' at %L",
3490 curr_comp
->name
, &(curr_comp
->loc
),
3491 derived_sym
->name
, &(derived_sym
->declared_at
));
3495 if (curr_comp
->attr
.proc_pointer
!= 0)
3497 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3498 " of the BIND(C) derived type '%s' at %L", curr_comp
->name
,
3499 &curr_comp
->loc
, derived_sym
->name
,
3500 &derived_sym
->declared_at
);
3504 /* The components cannot be allocatable.
3505 J3/04-007, Section 15.2.3, C1505. */
3506 if (curr_comp
->attr
.allocatable
!= 0)
3508 gfc_error ("Component '%s' at %L cannot have the "
3509 "ALLOCATABLE attribute because it is a member "
3510 "of the BIND(C) derived type '%s' at %L",
3511 curr_comp
->name
, &(curr_comp
->loc
),
3512 derived_sym
->name
, &(derived_sym
->declared_at
));
3516 /* BIND(C) derived types must have interoperable components. */
3517 if (curr_comp
->ts
.type
== BT_DERIVED
3518 && curr_comp
->ts
.u
.derived
->ts
.is_iso_c
!= 1
3519 && curr_comp
->ts
.u
.derived
!= derived_sym
)
3521 /* This should be allowed; the draft says a derived-type can not
3522 have type parameters if it is has the BIND attribute. Type
3523 parameters seem to be for making parameterized derived types.
3524 There's no need to verify the type if it is c_ptr/c_funptr. */
3525 retval
= verify_bind_c_derived_type (curr_comp
->ts
.u
.derived
);
3529 /* Grab the typespec for the given component and test the kind. */
3530 is_c_interop
= verify_c_interop (&(curr_comp
->ts
));
3532 if (is_c_interop
!= SUCCESS
)
3534 /* Report warning and continue since not fatal. The
3535 draft does specify a constraint that requires all fields
3536 to interoperate, but if the user says real(4), etc., it
3537 may interoperate with *something* in C, but the compiler
3538 most likely won't know exactly what. Further, it may not
3539 interoperate with the same data type(s) in C if the user
3540 recompiles with different flags (e.g., -m32 and -m64 on
3541 x86_64 and using integer(4) to claim interop with a
3543 if (derived_sym
->attr
.is_bind_c
== 1)
3544 /* If the derived type is bind(c), all fields must be
3546 gfc_warning ("Component '%s' in derived type '%s' at %L "
3547 "may not be C interoperable, even though "
3548 "derived type '%s' is BIND(C)",
3549 curr_comp
->name
, derived_sym
->name
,
3550 &(curr_comp
->loc
), derived_sym
->name
);
3552 /* If derived type is param to bind(c) routine, or to one
3553 of the iso_c_binding procs, it must be interoperable, so
3554 all fields must interop too. */
3555 gfc_warning ("Component '%s' in derived type '%s' at %L "
3556 "may not be C interoperable",
3557 curr_comp
->name
, derived_sym
->name
,
3562 curr_comp
= curr_comp
->next
;
3563 } while (curr_comp
!= NULL
);
3566 /* Make sure we don't have conflicts with the attributes. */
3567 if (derived_sym
->attr
.access
== ACCESS_PRIVATE
)
3569 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3570 "PRIVATE and BIND(C) attributes", derived_sym
->name
,
3571 &(derived_sym
->declared_at
));
3575 if (derived_sym
->attr
.sequence
!= 0)
3577 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3578 "attribute because it is BIND(C)", derived_sym
->name
,
3579 &(derived_sym
->declared_at
));
3583 /* Mark the derived type as not being C interoperable if we found an
3584 error. If there were only warnings, proceed with the assumption
3585 it's interoperable. */
3586 if (retval
== FAILURE
)
3587 derived_sym
->ts
.is_c_interop
= 0;
3593 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3596 gen_special_c_interop_ptr (int ptr_id
, const char *ptr_name
,
3597 const char *module_name
)
3599 gfc_symtree
*tmp_symtree
;
3600 gfc_symbol
*tmp_sym
;
3602 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, ptr_name
);
3604 if (tmp_symtree
!= NULL
)
3605 tmp_sym
= tmp_symtree
->n
.sym
;
3609 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3610 "create symbol for %s", ptr_name
);
3613 /* Set up the symbol's important fields. Save attr required so we can
3614 initialize the ptr to NULL. */
3615 tmp_sym
->attr
.save
= SAVE_EXPLICIT
;
3616 tmp_sym
->ts
.is_c_interop
= 1;
3617 tmp_sym
->attr
.is_c_interop
= 1;
3618 tmp_sym
->ts
.is_iso_c
= 1;
3619 tmp_sym
->ts
.type
= BT_DERIVED
;
3621 /* The c_ptr and c_funptr derived types will provide the
3622 definition for c_null_ptr and c_null_funptr, respectively. */
3623 if (ptr_id
== ISOCBINDING_NULL_PTR
)
3624 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3626 tmp_sym
->ts
.u
.derived
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3627 if (tmp_sym
->ts
.u
.derived
== NULL
)
3629 /* This can occur if the user forgot to declare c_ptr or
3630 c_funptr and they're trying to use one of the procedures
3631 that has arg(s) of the missing type. In this case, a
3632 regular version of the thing should have been put in the
3634 generate_isocbinding_symbol (module_name
, ptr_id
== ISOCBINDING_NULL_PTR
3635 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
,
3636 (const char *) (ptr_id
== ISOCBINDING_NULL_PTR
3637 ? "_gfortran_iso_c_binding_c_ptr"
3638 : "_gfortran_iso_c_binding_c_funptr"));
3640 tmp_sym
->ts
.u
.derived
=
3641 get_iso_c_binding_dt (ptr_id
== ISOCBINDING_NULL_PTR
3642 ? ISOCBINDING_PTR
: ISOCBINDING_FUNPTR
);
3645 /* Module name is some mangled version of iso_c_binding. */
3646 tmp_sym
->module
= gfc_get_string (module_name
);
3648 /* Say it's from the iso_c_binding module. */
3649 tmp_sym
->attr
.is_iso_c
= 1;
3651 tmp_sym
->attr
.use_assoc
= 1;
3652 tmp_sym
->attr
.is_bind_c
= 1;
3653 /* Set the binding_label. */
3654 sprintf (tmp_sym
->binding_label
, "%s_%s", module_name
, tmp_sym
->name
);
3656 /* Set the c_address field of c_null_ptr and c_null_funptr to
3657 the value of NULL. */
3658 tmp_sym
->value
= gfc_get_expr ();
3659 tmp_sym
->value
->expr_type
= EXPR_STRUCTURE
;
3660 tmp_sym
->value
->ts
.type
= BT_DERIVED
;
3661 tmp_sym
->value
->ts
.u
.derived
= tmp_sym
->ts
.u
.derived
;
3662 /* Create a constructor with no expr, that way we can recognize if the user
3663 tries to call the structure constructor for one of the iso_c_binding
3664 derived types during resolution (resolve_structure_cons). */
3665 tmp_sym
->value
->value
.constructor
= gfc_get_constructor ();
3666 /* Must declare c_null_ptr and c_null_funptr as having the
3667 PARAMETER attribute so they can be used in init expressions. */
3668 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
3674 /* Add a formal argument, gfc_formal_arglist, to the
3675 end of the given list of arguments. Set the reference to the
3676 provided symbol, param_sym, in the argument. */
3679 add_formal_arg (gfc_formal_arglist
**head
,
3680 gfc_formal_arglist
**tail
,
3681 gfc_formal_arglist
*formal_arg
,
3682 gfc_symbol
*param_sym
)
3684 /* Put in list, either as first arg or at the tail (curr arg). */
3686 *head
= *tail
= formal_arg
;
3689 (*tail
)->next
= formal_arg
;
3690 (*tail
) = formal_arg
;
3693 (*tail
)->sym
= param_sym
;
3694 (*tail
)->next
= NULL
;
3700 /* Generates a symbol representing the CPTR argument to an
3701 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3702 CPTR and add it to the provided argument list. */
3705 gen_cptr_param (gfc_formal_arglist
**head
,
3706 gfc_formal_arglist
**tail
,
3707 const char *module_name
,
3708 gfc_namespace
*ns
, const char *c_ptr_name
,
3711 gfc_symbol
*param_sym
= NULL
;
3712 gfc_symbol
*c_ptr_sym
= NULL
;
3713 gfc_symtree
*param_symtree
= NULL
;
3714 gfc_formal_arglist
*formal_arg
= NULL
;
3715 const char *c_ptr_in
;
3716 const char *c_ptr_type
= NULL
;
3718 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3719 c_ptr_type
= "_gfortran_iso_c_binding_c_funptr";
3721 c_ptr_type
= "_gfortran_iso_c_binding_c_ptr";
3723 if(c_ptr_name
== NULL
)
3724 c_ptr_in
= "gfc_cptr__";
3726 c_ptr_in
= c_ptr_name
;
3727 gfc_get_sym_tree (c_ptr_in
, ns
, ¶m_symtree
, false);
3728 if (param_symtree
!= NULL
)
3729 param_sym
= param_symtree
->n
.sym
;
3731 gfc_internal_error ("gen_cptr_param(): Unable to "
3732 "create symbol for %s", c_ptr_in
);
3734 /* Set up the appropriate fields for the new c_ptr param sym. */
3736 param_sym
->attr
.flavor
= FL_DERIVED
;
3737 param_sym
->ts
.type
= BT_DERIVED
;
3738 param_sym
->attr
.intent
= INTENT_IN
;
3739 param_sym
->attr
.dummy
= 1;
3741 /* This will pass the ptr to the iso_c routines as a (void *). */
3742 param_sym
->attr
.value
= 1;
3743 param_sym
->attr
.use_assoc
= 1;
3745 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3747 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3748 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
3750 c_ptr_sym
= get_iso_c_binding_dt (ISOCBINDING_PTR
);
3751 if (c_ptr_sym
== NULL
)
3753 /* This can happen if the user did not define c_ptr but they are
3754 trying to use one of the iso_c_binding functions that need it. */
3755 if (iso_c_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3756 generate_isocbinding_symbol (module_name
, ISOCBINDING_FUNPTR
,
3757 (const char *)c_ptr_type
);
3759 generate_isocbinding_symbol (module_name
, ISOCBINDING_PTR
,
3760 (const char *)c_ptr_type
);
3762 gfc_get_ha_symbol (c_ptr_type
, &(c_ptr_sym
));
3765 param_sym
->ts
.u
.derived
= c_ptr_sym
;
3766 param_sym
->module
= gfc_get_string (module_name
);
3768 /* Make new formal arg. */
3769 formal_arg
= gfc_get_formal_arglist ();
3770 /* Add arg to list of formal args (the CPTR arg). */
3771 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3775 /* Generates a symbol representing the FPTR argument to an
3776 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3777 FPTR and add it to the provided argument list. */
3780 gen_fptr_param (gfc_formal_arglist
**head
,
3781 gfc_formal_arglist
**tail
,
3782 const char *module_name
,
3783 gfc_namespace
*ns
, const char *f_ptr_name
, int proc
)
3785 gfc_symbol
*param_sym
= NULL
;
3786 gfc_symtree
*param_symtree
= NULL
;
3787 gfc_formal_arglist
*formal_arg
= NULL
;
3788 const char *f_ptr_out
= "gfc_fptr__";
3790 if (f_ptr_name
!= NULL
)
3791 f_ptr_out
= f_ptr_name
;
3793 gfc_get_sym_tree (f_ptr_out
, ns
, ¶m_symtree
, false);
3794 if (param_symtree
!= NULL
)
3795 param_sym
= param_symtree
->n
.sym
;
3797 gfc_internal_error ("generateFPtrParam(): Unable to "
3798 "create symbol for %s", f_ptr_out
);
3800 /* Set up the necessary fields for the fptr output param sym. */
3803 param_sym
->attr
.proc_pointer
= 1;
3805 param_sym
->attr
.pointer
= 1;
3806 param_sym
->attr
.dummy
= 1;
3807 param_sym
->attr
.use_assoc
= 1;
3809 /* ISO C Binding type to allow any pointer type as actual param. */
3810 param_sym
->ts
.type
= BT_VOID
;
3811 param_sym
->module
= gfc_get_string (module_name
);
3814 formal_arg
= gfc_get_formal_arglist ();
3815 /* Add arg to list of formal args. */
3816 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3820 /* Generates a symbol representing the optional SHAPE argument for the
3821 iso_c_binding c_f_pointer() procedure. Also, create a
3822 gfc_formal_arglist for the SHAPE and add it to the provided
3826 gen_shape_param (gfc_formal_arglist
**head
,
3827 gfc_formal_arglist
**tail
,
3828 const char *module_name
,
3829 gfc_namespace
*ns
, const char *shape_param_name
)
3831 gfc_symbol
*param_sym
= NULL
;
3832 gfc_symtree
*param_symtree
= NULL
;
3833 gfc_formal_arglist
*formal_arg
= NULL
;
3834 const char *shape_param
= "gfc_shape_array__";
3837 if (shape_param_name
!= NULL
)
3838 shape_param
= shape_param_name
;
3840 gfc_get_sym_tree (shape_param
, ns
, ¶m_symtree
, false);
3841 if (param_symtree
!= NULL
)
3842 param_sym
= param_symtree
->n
.sym
;
3844 gfc_internal_error ("generateShapeParam(): Unable to "
3845 "create symbol for %s", shape_param
);
3847 /* Set up the necessary fields for the shape input param sym. */
3849 param_sym
->attr
.dummy
= 1;
3850 param_sym
->attr
.use_assoc
= 1;
3852 /* Integer array, rank 1, describing the shape of the object. Make it's
3853 type BT_VOID initially so we can accept any type/kind combination of
3854 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3855 of BT_INTEGER type. */
3856 param_sym
->ts
.type
= BT_VOID
;
3858 /* Initialize the kind to default integer. However, it will be overridden
3859 during resolution to match the kind of the SHAPE parameter given as
3860 the actual argument (to allow for any valid integer kind). */
3861 param_sym
->ts
.kind
= gfc_default_integer_kind
;
3862 param_sym
->as
= gfc_get_array_spec ();
3864 /* Clear out the dimension info for the array. */
3865 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3867 param_sym
->as
->lower
[i
] = NULL
;
3868 param_sym
->as
->upper
[i
] = NULL
;
3870 param_sym
->as
->rank
= 1;
3871 param_sym
->as
->lower
[0] = gfc_int_expr (1);
3873 /* The extent is unknown until we get it. The length give us
3874 the rank the incoming pointer. */
3875 param_sym
->as
->type
= AS_ASSUMED_SHAPE
;
3877 /* The arg is also optional; it is required iff the second arg
3878 (fptr) is to an array, otherwise, it's ignored. */
3879 param_sym
->attr
.optional
= 1;
3880 param_sym
->attr
.intent
= INTENT_IN
;
3881 param_sym
->attr
.dimension
= 1;
3882 param_sym
->module
= gfc_get_string (module_name
);
3885 formal_arg
= gfc_get_formal_arglist ();
3886 /* Add arg to list of formal args. */
3887 add_formal_arg (head
, tail
, formal_arg
, param_sym
);
3891 /* Add a procedure interface to the given symbol (i.e., store a
3892 reference to the list of formal arguments). */
3895 add_proc_interface (gfc_symbol
*sym
, ifsrc source
,
3896 gfc_formal_arglist
*formal
)
3899 sym
->formal
= formal
;
3900 sym
->attr
.if_source
= source
;
3904 /* Copy the formal args from an existing symbol, src, into a new
3905 symbol, dest. New formal args are created, and the description of
3906 each arg is set according to the existing ones. This function is
3907 used when creating procedure declaration variables from a procedure
3908 declaration statement (see match_proc_decl()) to create the formal
3909 args based on the args of a given named interface. */
3912 gfc_copy_formal_args (gfc_symbol
*dest
, gfc_symbol
*src
)
3914 gfc_formal_arglist
*head
= NULL
;
3915 gfc_formal_arglist
*tail
= NULL
;
3916 gfc_formal_arglist
*formal_arg
= NULL
;
3917 gfc_formal_arglist
*curr_arg
= NULL
;
3918 gfc_formal_arglist
*formal_prev
= NULL
;
3919 /* Save current namespace so we can change it for formal args. */
3920 gfc_namespace
*parent_ns
= gfc_current_ns
;
3922 /* Create a new namespace, which will be the formal ns (namespace
3923 of the formal args). */
3924 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3925 gfc_current_ns
->proc_name
= dest
;
3927 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3929 formal_arg
= gfc_get_formal_arglist ();
3930 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3932 /* May need to copy more info for the symbol. */
3933 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
3934 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
3935 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
3936 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
3938 /* If this isn't the first arg, set up the next ptr. For the
3939 last arg built, the formal_arg->next will never get set to
3940 anything other than NULL. */
3941 if (formal_prev
!= NULL
)
3942 formal_prev
->next
= formal_arg
;
3944 formal_arg
->next
= NULL
;
3946 formal_prev
= formal_arg
;
3948 /* Add arg to list of formal args. */
3949 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
3952 /* Add the interface to the symbol. */
3953 add_proc_interface (dest
, IFSRC_DECL
, head
);
3955 /* Store the formal namespace information. */
3956 if (dest
->formal
!= NULL
)
3957 /* The current ns should be that for the dest proc. */
3958 dest
->formal_ns
= gfc_current_ns
;
3959 /* Restore the current namespace to what it was on entry. */
3960 gfc_current_ns
= parent_ns
;
3965 gfc_copy_formal_args_intr (gfc_symbol
*dest
, gfc_intrinsic_sym
*src
)
3967 gfc_formal_arglist
*head
= NULL
;
3968 gfc_formal_arglist
*tail
= NULL
;
3969 gfc_formal_arglist
*formal_arg
= NULL
;
3970 gfc_intrinsic_arg
*curr_arg
= NULL
;
3971 gfc_formal_arglist
*formal_prev
= NULL
;
3972 /* Save current namespace so we can change it for formal args. */
3973 gfc_namespace
*parent_ns
= gfc_current_ns
;
3975 /* Create a new namespace, which will be the formal ns (namespace
3976 of the formal args). */
3977 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
3978 gfc_current_ns
->proc_name
= dest
;
3980 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
3982 formal_arg
= gfc_get_formal_arglist ();
3983 gfc_get_symbol (curr_arg
->name
, gfc_current_ns
, &(formal_arg
->sym
));
3985 /* May need to copy more info for the symbol. */
3986 formal_arg
->sym
->ts
= curr_arg
->ts
;
3987 formal_arg
->sym
->attr
.optional
= curr_arg
->optional
;
3988 formal_arg
->sym
->attr
.intent
= curr_arg
->intent
;
3989 formal_arg
->sym
->attr
.flavor
= FL_VARIABLE
;
3990 formal_arg
->sym
->attr
.dummy
= 1;
3992 if (formal_arg
->sym
->ts
.type
== BT_CHARACTER
)
3993 formal_arg
->sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3995 /* If this isn't the first arg, set up the next ptr. For the
3996 last arg built, the formal_arg->next will never get set to
3997 anything other than NULL. */
3998 if (formal_prev
!= NULL
)
3999 formal_prev
->next
= formal_arg
;
4001 formal_arg
->next
= NULL
;
4003 formal_prev
= formal_arg
;
4005 /* Add arg to list of formal args. */
4006 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4009 /* Add the interface to the symbol. */
4010 add_proc_interface (dest
, IFSRC_DECL
, head
);
4012 /* Store the formal namespace information. */
4013 if (dest
->formal
!= NULL
)
4014 /* The current ns should be that for the dest proc. */
4015 dest
->formal_ns
= gfc_current_ns
;
4016 /* Restore the current namespace to what it was on entry. */
4017 gfc_current_ns
= parent_ns
;
4022 gfc_copy_formal_args_ppc (gfc_component
*dest
, gfc_symbol
*src
)
4024 gfc_formal_arglist
*head
= NULL
;
4025 gfc_formal_arglist
*tail
= NULL
;
4026 gfc_formal_arglist
*formal_arg
= NULL
;
4027 gfc_formal_arglist
*curr_arg
= NULL
;
4028 gfc_formal_arglist
*formal_prev
= NULL
;
4029 /* Save current namespace so we can change it for formal args. */
4030 gfc_namespace
*parent_ns
= gfc_current_ns
;
4032 /* Create a new namespace, which will be the formal ns (namespace
4033 of the formal args). */
4034 gfc_current_ns
= gfc_get_namespace (parent_ns
, 0);
4035 /* TODO: gfc_current_ns->proc_name = dest;*/
4037 for (curr_arg
= src
->formal
; curr_arg
; curr_arg
= curr_arg
->next
)
4039 formal_arg
= gfc_get_formal_arglist ();
4040 gfc_get_symbol (curr_arg
->sym
->name
, gfc_current_ns
, &(formal_arg
->sym
));
4042 /* May need to copy more info for the symbol. */
4043 formal_arg
->sym
->attr
= curr_arg
->sym
->attr
;
4044 formal_arg
->sym
->ts
= curr_arg
->sym
->ts
;
4045 formal_arg
->sym
->as
= gfc_copy_array_spec (curr_arg
->sym
->as
);
4046 gfc_copy_formal_args (formal_arg
->sym
, curr_arg
->sym
);
4048 /* If this isn't the first arg, set up the next ptr. For the
4049 last arg built, the formal_arg->next will never get set to
4050 anything other than NULL. */
4051 if (formal_prev
!= NULL
)
4052 formal_prev
->next
= formal_arg
;
4054 formal_arg
->next
= NULL
;
4056 formal_prev
= formal_arg
;
4058 /* Add arg to list of formal args. */
4059 add_formal_arg (&head
, &tail
, formal_arg
, formal_arg
->sym
);
4062 /* Add the interface to the symbol. */
4063 dest
->formal
= head
;
4064 dest
->attr
.if_source
= IFSRC_DECL
;
4066 /* Store the formal namespace information. */
4067 if (dest
->formal
!= NULL
)
4068 /* The current ns should be that for the dest proc. */
4069 dest
->formal_ns
= gfc_current_ns
;
4070 /* Restore the current namespace to what it was on entry. */
4071 gfc_current_ns
= parent_ns
;
4075 /* Builds the parameter list for the iso_c_binding procedure
4076 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4077 generic version of either the c_f_pointer or c_f_procpointer
4078 functions. The new_proc_sym represents a "resolved" version of the
4079 symbol. The functions are resolved to match the types of their
4080 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4081 something similar to c_f_pointer_i4 if the type of data object fptr
4082 pointed to was a default integer. The actual name of the resolved
4083 procedure symbol is further mangled with the module name, etc., but
4084 the idea holds true. */
4087 build_formal_args (gfc_symbol
*new_proc_sym
,
4088 gfc_symbol
*old_sym
, int add_optional_arg
)
4090 gfc_formal_arglist
*head
= NULL
, *tail
= NULL
;
4091 gfc_namespace
*parent_ns
= NULL
;
4093 parent_ns
= gfc_current_ns
;
4094 /* Create a new namespace, which will be the formal ns (namespace
4095 of the formal args). */
4096 gfc_current_ns
= gfc_get_namespace(parent_ns
, 0);
4097 gfc_current_ns
->proc_name
= new_proc_sym
;
4099 /* Generate the params. */
4100 if (old_sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
4102 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4103 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4104 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4105 gfc_current_ns
, "fptr", 1);
4107 else if (old_sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
4109 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4110 gfc_current_ns
, "cptr", old_sym
->intmod_sym_id
);
4111 gen_fptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4112 gfc_current_ns
, "fptr", 0);
4113 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4114 gen_shape_param (&head
, &tail
,(const char *) new_proc_sym
->module
,
4115 gfc_current_ns
, "shape");
4118 else if (old_sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
4120 /* c_associated has one required arg and one optional; both
4122 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4123 gfc_current_ns
, "c_ptr_1", ISOCBINDING_ASSOCIATED
);
4124 if (add_optional_arg
)
4126 gen_cptr_param (&head
, &tail
, (const char *) new_proc_sym
->module
,
4127 gfc_current_ns
, "c_ptr_2", ISOCBINDING_ASSOCIATED
);
4128 /* The last param is optional so mark it as such. */
4129 tail
->sym
->attr
.optional
= 1;
4133 /* Add the interface (store formal args to new_proc_sym). */
4134 add_proc_interface (new_proc_sym
, IFSRC_DECL
, head
);
4136 /* Set up the formal_ns pointer to the one created for the
4137 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4138 new_proc_sym
->formal_ns
= gfc_current_ns
;
4140 gfc_current_ns
= parent_ns
;
4144 std_for_isocbinding_symbol (int id
)
4148 #define NAMED_INTCST(a,b,c,d) \
4151 #include "iso-c-binding.def"
4154 return GFC_STD_F2003
;
4158 /* Generate the given set of C interoperable kind objects, or all
4159 interoperable kinds. This function will only be given kind objects
4160 for valid iso_c_binding defined types because this is verified when
4161 the 'use' statement is parsed. If the user gives an 'only' clause,
4162 the specific kinds are looked up; if they don't exist, an error is
4163 reported. If the user does not give an 'only' clause, all
4164 iso_c_binding symbols are generated. If a list of specific kinds
4165 is given, it must have a NULL in the first empty spot to mark the
4170 generate_isocbinding_symbol (const char *mod_name
, iso_c_binding_symbol s
,
4171 const char *local_name
)
4173 const char *const name
= (local_name
&& local_name
[0]) ? local_name
4174 : c_interop_kinds_table
[s
].name
;
4175 gfc_symtree
*tmp_symtree
= NULL
;
4176 gfc_symbol
*tmp_sym
= NULL
;
4177 gfc_dt_list
**dt_list_ptr
= NULL
;
4178 gfc_component
*tmp_comp
= NULL
;
4179 char comp_name
[(GFC_MAX_SYMBOL_LEN
* 2) + 1];
4182 if (gfc_notification_std (std_for_isocbinding_symbol (s
)) == ERROR
)
4184 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4186 /* Already exists in this scope so don't re-add it.
4187 TODO: we should probably check that it's really the same symbol. */
4188 if (tmp_symtree
!= NULL
)
4191 /* Create the sym tree in the current ns. */
4192 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
4194 tmp_sym
= tmp_symtree
->n
.sym
;
4196 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4199 /* Say what module this symbol belongs to. */
4200 tmp_sym
->module
= gfc_get_string (mod_name
);
4201 tmp_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4202 tmp_sym
->intmod_sym_id
= s
;
4207 #define NAMED_INTCST(a,b,c,d) case a :
4208 #define NAMED_REALCST(a,b,c) case a :
4209 #define NAMED_CMPXCST(a,b,c) case a :
4210 #define NAMED_LOGCST(a,b,c) case a :
4211 #define NAMED_CHARKNDCST(a,b,c) case a :
4212 #include "iso-c-binding.def"
4214 tmp_sym
->value
= gfc_int_expr (c_interop_kinds_table
[s
].value
);
4216 /* Initialize an integer constant expression node. */
4217 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4218 tmp_sym
->ts
.type
= BT_INTEGER
;
4219 tmp_sym
->ts
.kind
= gfc_default_integer_kind
;
4221 /* Mark this type as a C interoperable one. */
4222 tmp_sym
->ts
.is_c_interop
= 1;
4223 tmp_sym
->ts
.is_iso_c
= 1;
4224 tmp_sym
->value
->ts
.is_c_interop
= 1;
4225 tmp_sym
->value
->ts
.is_iso_c
= 1;
4226 tmp_sym
->attr
.is_c_interop
= 1;
4228 /* Tell what f90 type this c interop kind is valid. */
4229 tmp_sym
->ts
.f90_type
= c_interop_kinds_table
[s
].f90_type
;
4231 /* Say it's from the iso_c_binding module. */
4232 tmp_sym
->attr
.is_iso_c
= 1;
4234 /* Make it use associated. */
4235 tmp_sym
->attr
.use_assoc
= 1;
4239 #define NAMED_CHARCST(a,b,c) case a :
4240 #include "iso-c-binding.def"
4242 /* Initialize an integer constant expression node for the
4243 length of the character. */
4244 tmp_sym
->value
= gfc_get_expr ();
4245 tmp_sym
->value
->expr_type
= EXPR_CONSTANT
;
4246 tmp_sym
->value
->ts
.type
= BT_CHARACTER
;
4247 tmp_sym
->value
->ts
.kind
= gfc_default_character_kind
;
4248 tmp_sym
->value
->where
= gfc_current_locus
;
4249 tmp_sym
->value
->ts
.is_c_interop
= 1;
4250 tmp_sym
->value
->ts
.is_iso_c
= 1;
4251 tmp_sym
->value
->value
.character
.length
= 1;
4252 tmp_sym
->value
->value
.character
.string
= gfc_get_wide_string (2);
4253 tmp_sym
->value
->value
.character
.string
[0]
4254 = (gfc_char_t
) c_interop_kinds_table
[s
].value
;
4255 tmp_sym
->value
->value
.character
.string
[1] = '\0';
4256 tmp_sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4257 tmp_sym
->ts
.u
.cl
->length
= gfc_int_expr (1);
4259 /* May not need this in both attr and ts, but do need in
4260 attr for writing module file. */
4261 tmp_sym
->attr
.is_c_interop
= 1;
4263 tmp_sym
->attr
.flavor
= FL_PARAMETER
;
4264 tmp_sym
->ts
.type
= BT_CHARACTER
;
4266 /* Need to set it to the C_CHAR kind. */
4267 tmp_sym
->ts
.kind
= gfc_default_character_kind
;
4269 /* Mark this type as a C interoperable one. */
4270 tmp_sym
->ts
.is_c_interop
= 1;
4271 tmp_sym
->ts
.is_iso_c
= 1;
4273 /* Tell what f90 type this c interop kind is valid. */
4274 tmp_sym
->ts
.f90_type
= BT_CHARACTER
;
4276 /* Say it's from the iso_c_binding module. */
4277 tmp_sym
->attr
.is_iso_c
= 1;
4279 /* Make it use associated. */
4280 tmp_sym
->attr
.use_assoc
= 1;
4283 case ISOCBINDING_PTR
:
4284 case ISOCBINDING_FUNPTR
:
4286 /* Initialize an integer constant expression node. */
4287 tmp_sym
->attr
.flavor
= FL_DERIVED
;
4288 tmp_sym
->ts
.is_c_interop
= 1;
4289 tmp_sym
->attr
.is_c_interop
= 1;
4290 tmp_sym
->attr
.is_iso_c
= 1;
4291 tmp_sym
->ts
.is_iso_c
= 1;
4292 tmp_sym
->ts
.type
= BT_DERIVED
;
4294 /* A derived type must have the bind attribute to be
4295 interoperable (J3/04-007, Section 15.2.3), even though
4296 the binding label is not used. */
4297 tmp_sym
->attr
.is_bind_c
= 1;
4299 tmp_sym
->attr
.referenced
= 1;
4301 tmp_sym
->ts
.u
.derived
= tmp_sym
;
4303 /* Add the symbol created for the derived type to the current ns. */
4304 dt_list_ptr
= &(gfc_derived_types
);
4305 while (*dt_list_ptr
!= NULL
&& (*dt_list_ptr
)->next
!= NULL
)
4306 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4308 /* There is already at least one derived type in the list, so append
4309 the one we're currently building for c_ptr or c_funptr. */
4310 if (*dt_list_ptr
!= NULL
)
4311 dt_list_ptr
= &((*dt_list_ptr
)->next
);
4312 (*dt_list_ptr
) = gfc_get_dt_list ();
4313 (*dt_list_ptr
)->derived
= tmp_sym
;
4314 (*dt_list_ptr
)->next
= NULL
;
4316 /* Set up the component of the derived type, which will be
4317 an integer with kind equal to c_ptr_size. Mangle the name of
4318 the field for the c_address to prevent the curious user from
4319 trying to access it from Fortran. */
4320 sprintf (comp_name
, "__%s_%s", tmp_sym
->name
, "c_address");
4321 gfc_add_component (tmp_sym
, comp_name
, &tmp_comp
);
4322 if (tmp_comp
== NULL
)
4323 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4324 "create component for c_address");
4326 tmp_comp
->ts
.type
= BT_INTEGER
;
4328 /* Set this because the module will need to read/write this field. */
4329 tmp_comp
->ts
.f90_type
= BT_INTEGER
;
4331 /* The kinds for c_ptr and c_funptr are the same. */
4332 index
= get_c_kind ("c_ptr", c_interop_kinds_table
);
4333 tmp_comp
->ts
.kind
= c_interop_kinds_table
[index
].value
;
4335 tmp_comp
->attr
.pointer
= 0;
4336 tmp_comp
->attr
.dimension
= 0;
4338 /* Mark the component as C interoperable. */
4339 tmp_comp
->ts
.is_c_interop
= 1;
4341 /* Make it use associated (iso_c_binding module). */
4342 tmp_sym
->attr
.use_assoc
= 1;
4345 case ISOCBINDING_NULL_PTR
:
4346 case ISOCBINDING_NULL_FUNPTR
:
4347 gen_special_c_interop_ptr (s
, name
, mod_name
);
4350 case ISOCBINDING_F_POINTER
:
4351 case ISOCBINDING_ASSOCIATED
:
4352 case ISOCBINDING_LOC
:
4353 case ISOCBINDING_FUNLOC
:
4354 case ISOCBINDING_F_PROCPOINTER
:
4356 tmp_sym
->attr
.proc
= PROC_MODULE
;
4358 /* Use the procedure's name as it is in the iso_c_binding module for
4359 setting the binding label in case the user renamed the symbol. */
4360 sprintf (tmp_sym
->binding_label
, "%s_%s", mod_name
,
4361 c_interop_kinds_table
[s
].name
);
4362 tmp_sym
->attr
.is_iso_c
= 1;
4363 if (s
== ISOCBINDING_F_POINTER
|| s
== ISOCBINDING_F_PROCPOINTER
)
4364 tmp_sym
->attr
.subroutine
= 1;
4367 /* TODO! This needs to be finished more for the expr of the
4368 function or something!
4369 This may not need to be here, because trying to do c_loc
4371 if (s
== ISOCBINDING_ASSOCIATED
)
4373 tmp_sym
->attr
.function
= 1;
4374 tmp_sym
->ts
.type
= BT_LOGICAL
;
4375 tmp_sym
->ts
.kind
= gfc_default_logical_kind
;
4376 tmp_sym
->result
= tmp_sym
;
4380 /* Here, we're taking the simple approach. We're defining
4381 c_loc as an external identifier so the compiler will put
4382 what we expect on the stack for the address we want the
4384 tmp_sym
->ts
.type
= BT_DERIVED
;
4385 if (s
== ISOCBINDING_LOC
)
4386 tmp_sym
->ts
.u
.derived
=
4387 get_iso_c_binding_dt (ISOCBINDING_PTR
);
4389 tmp_sym
->ts
.u
.derived
=
4390 get_iso_c_binding_dt (ISOCBINDING_FUNPTR
);
4392 if (tmp_sym
->ts
.u
.derived
== NULL
)
4394 /* Create the necessary derived type so we can continue
4395 processing the file. */
4396 generate_isocbinding_symbol
4397 (mod_name
, s
== ISOCBINDING_FUNLOC
4398 ? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR
,
4399 (const char *)(s
== ISOCBINDING_FUNLOC
4400 ? "_gfortran_iso_c_binding_c_funptr"
4401 : "_gfortran_iso_c_binding_c_ptr"));
4402 tmp_sym
->ts
.u
.derived
=
4403 get_iso_c_binding_dt (s
== ISOCBINDING_FUNLOC
4404 ? ISOCBINDING_FUNPTR
4408 /* The function result is itself (no result clause). */
4409 tmp_sym
->result
= tmp_sym
;
4410 tmp_sym
->attr
.external
= 1;
4411 tmp_sym
->attr
.use_assoc
= 0;
4412 tmp_sym
->attr
.pure
= 1;
4413 tmp_sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4414 tmp_sym
->attr
.proc
= PROC_UNKNOWN
;
4418 tmp_sym
->attr
.flavor
= FL_PROCEDURE
;
4419 tmp_sym
->attr
.contained
= 0;
4421 /* Try using this builder routine, with the new and old symbols
4422 both being the generic iso_c proc sym being created. This
4423 will create the formal args (and the new namespace for them).
4424 Don't build an arg list for c_loc because we're going to treat
4425 c_loc as an external procedure. */
4426 if (s
!= ISOCBINDING_LOC
&& s
!= ISOCBINDING_FUNLOC
)
4427 /* The 1 says to add any optional args, if applicable. */
4428 build_formal_args (tmp_sym
, tmp_sym
, 1);
4430 /* Set this after setting up the symbol, to prevent error messages. */
4431 tmp_sym
->attr
.use_assoc
= 1;
4433 /* This symbol will not be referenced directly. It will be
4434 resolved to the implementation for the given f90 kind. */
4435 tmp_sym
->attr
.referenced
= 0;
4445 /* Creates a new symbol based off of an old iso_c symbol, with a new
4446 binding label. This function can be used to create a new,
4447 resolved, version of a procedure symbol for c_f_pointer or
4448 c_f_procpointer that is based on the generic symbols. A new
4449 parameter list is created for the new symbol using
4450 build_formal_args(). The add_optional_flag specifies whether the
4451 to add the optional SHAPE argument. The new symbol is
4455 get_iso_c_sym (gfc_symbol
*old_sym
, char *new_name
,
4456 char *new_binding_label
, int add_optional_arg
)
4458 gfc_symtree
*new_symtree
= NULL
;
4460 /* See if we have a symbol by that name already available, looking
4461 through any parent namespaces. */
4462 gfc_find_sym_tree (new_name
, gfc_current_ns
, 1, &new_symtree
);
4463 if (new_symtree
!= NULL
)
4464 /* Return the existing symbol. */
4465 return new_symtree
->n
.sym
;
4467 /* Create the symtree/symbol, with attempted host association. */
4468 gfc_get_ha_sym_tree (new_name
, &new_symtree
);
4469 if (new_symtree
== NULL
)
4470 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4471 "symtree for '%s'", new_name
);
4473 /* Now fill in the fields of the resolved symbol with the old sym. */
4474 strcpy (new_symtree
->n
.sym
->binding_label
, new_binding_label
);
4475 new_symtree
->n
.sym
->attr
= old_sym
->attr
;
4476 new_symtree
->n
.sym
->ts
= old_sym
->ts
;
4477 new_symtree
->n
.sym
->module
= gfc_get_string (old_sym
->module
);
4478 new_symtree
->n
.sym
->from_intmod
= old_sym
->from_intmod
;
4479 new_symtree
->n
.sym
->intmod_sym_id
= old_sym
->intmod_sym_id
;
4480 /* Build the formal arg list. */
4481 build_formal_args (new_symtree
->n
.sym
, old_sym
, add_optional_arg
);
4483 gfc_commit_symbol (new_symtree
->n
.sym
);
4485 return new_symtree
->n
.sym
;
4489 /* Check that a symbol is already typed. If strict is not set, an untyped
4490 symbol is acceptable for non-standard-conforming mode. */
4493 gfc_check_symbol_typed (gfc_symbol
* sym
, gfc_namespace
* ns
,
4494 bool strict
, locus where
)
4498 if (gfc_matching_prefix
)
4501 /* Check for the type and try to give it an implicit one. */
4502 if (sym
->ts
.type
== BT_UNKNOWN
4503 && gfc_set_default_type (sym
, 0, ns
) == FAILURE
)
4507 gfc_error ("Symbol '%s' is used before it is typed at %L",
4512 if (gfc_notify_std (GFC_STD_GNU
,
4513 "Extension: Symbol '%s' is used before"
4514 " it is typed at %L", sym
->name
, &where
) == FAILURE
)
4518 /* Everything is ok. */
4523 /* Construct a typebound-procedure structure. Those are stored in a tentative
4524 list and marked `error' until symbols are committed. */
4527 gfc_get_typebound_proc (void)
4529 gfc_typebound_proc
*result
;
4530 tentative_tbp
*list_node
;
4532 result
= XCNEW (gfc_typebound_proc
);
4535 list_node
= XCNEW (tentative_tbp
);
4536 list_node
->next
= tentative_tbp_list
;
4537 list_node
->proc
= result
;
4538 tentative_tbp_list
= list_node
;
4544 /* Get the super-type of a given derived type. */
4547 gfc_get_derived_super_type (gfc_symbol
* derived
)
4549 if (!derived
->attr
.extension
)
4552 gcc_assert (derived
->components
);
4553 gcc_assert (derived
->components
->ts
.type
== BT_DERIVED
);
4554 gcc_assert (derived
->components
->ts
.u
.derived
);
4556 return derived
->components
->ts
.u
.derived
;
4560 /* Get the ultimate super-type of a given derived type. */
4563 gfc_get_ultimate_derived_super_type (gfc_symbol
* derived
)
4565 if (!derived
->attr
.extension
)
4568 derived
= gfc_get_derived_super_type (derived
);
4570 if (derived
->attr
.extension
)
4571 return gfc_get_ultimate_derived_super_type (derived
);
4577 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4580 gfc_type_is_extension_of (gfc_symbol
*t1
, gfc_symbol
*t2
)
4582 while (!gfc_compare_derived_types (t1
, t2
) && t2
->attr
.extension
)
4583 t2
= gfc_get_derived_super_type (t2
);
4584 return gfc_compare_derived_types (t1
, t2
);
4588 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4589 If ts1 is nonpolymorphic, ts2 must be the same type.
4590 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4593 gfc_type_compatible (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
4595 if ((ts1
->type
== BT_DERIVED
|| ts1
->type
== BT_CLASS
)
4596 && (ts2
->type
== BT_DERIVED
|| ts2
->type
== BT_CLASS
))
4598 if (ts1
->type
== BT_CLASS
&& ts2
->type
== BT_DERIVED
)
4599 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4601 else if (ts1
->type
== BT_CLASS
&& ts2
->type
== BT_CLASS
)
4602 return gfc_type_is_extension_of (ts1
->u
.derived
->components
->ts
.u
.derived
,
4603 ts2
->u
.derived
->components
->ts
.u
.derived
);
4604 else if (ts2
->type
!= BT_CLASS
)
4605 return gfc_compare_derived_types (ts1
->u
.derived
, ts2
->u
.derived
);
4610 return (ts1
->type
== ts2
->type
);
4614 /* General worker function to find either a type-bound procedure or a
4615 type-bound user operator. */
4618 find_typebound_proc_uop (gfc_symbol
* derived
, gfc_try
* t
,
4619 const char* name
, bool noaccess
, bool uop
,
4625 /* Set correct symbol-root. */
4626 gcc_assert (derived
->f2k_derived
);
4627 root
= (uop
? derived
->f2k_derived
->tb_uop_root
4628 : derived
->f2k_derived
->tb_sym_root
);
4630 /* Set default to failure. */
4634 /* Try to find it in the current type's namespace. */
4635 res
= gfc_find_symtree (root
, name
);
4636 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
4642 if (!noaccess
&& derived
->attr
.use_assoc
4643 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
4646 gfc_error ("'%s' of '%s' is PRIVATE at %L",
4647 name
, derived
->name
, where
);
4655 /* Otherwise, recurse on parent type if derived is an extension. */
4656 if (derived
->attr
.extension
)
4658 gfc_symbol
* super_type
;
4659 super_type
= gfc_get_derived_super_type (derived
);
4660 gcc_assert (super_type
);
4662 return find_typebound_proc_uop (super_type
, t
, name
,
4663 noaccess
, uop
, where
);
4666 /* Nothing found. */
4671 /* Find a type-bound procedure or user operator by name for a derived-type
4672 (looking recursively through the super-types). */
4675 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
4676 const char* name
, bool noaccess
, locus
* where
)
4678 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
4682 gfc_find_typebound_user_op (gfc_symbol
* derived
, gfc_try
* t
,
4683 const char* name
, bool noaccess
, locus
* where
)
4685 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
4689 /* Find a type-bound intrinsic operator looking recursively through the
4690 super-type hierarchy. */
4693 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_try
* t
,
4694 gfc_intrinsic_op op
, bool noaccess
,
4697 gfc_typebound_proc
* res
;
4699 /* Set default to failure. */
4703 /* Try to find it in the current type's namespace. */
4704 if (derived
->f2k_derived
)
4705 res
= derived
->f2k_derived
->tb_op
[op
];
4710 if (res
&& !res
->error
)
4716 if (!noaccess
&& derived
->attr
.use_assoc
4717 && res
->access
== ACCESS_PRIVATE
)
4720 gfc_error ("'%s' of '%s' is PRIVATE at %L",
4721 gfc_op2string (op
), derived
->name
, where
);
4729 /* Otherwise, recurse on parent type if derived is an extension. */
4730 if (derived
->attr
.extension
)
4732 gfc_symbol
* super_type
;
4733 super_type
= gfc_get_derived_super_type (derived
);
4734 gcc_assert (super_type
);
4736 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
4740 /* Nothing found. */
4745 /* Get a typebound-procedure symtree or create and insert it if not yet
4746 present. This is like a very simplified version of gfc_get_sym_tree for
4747 tbp-symtrees rather than regular ones. */
4750 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
4752 gfc_symtree
*result
;
4754 result
= gfc_find_symtree (*root
, name
);
4757 result
= gfc_new_symtree (root
, name
);
4758 gcc_assert (result
);
4759 result
->n
.tb
= NULL
;