1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2020 Free Software Foundation, Inc.
3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 and Janus Weil <janus@gcc.gnu.org>
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/>. */
23 /* class.c -- This file contains the front end functions needed to service
24 the implementation of Fortran 2003 polymorphism and other
25 object-oriented features. */
28 /* Outline of the internal representation:
30 Each CLASS variable is encapsulated by a class container, which is a
31 structure with two fields:
32 * _data: A pointer to the actual data of the variable. This field has the
33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...).
35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
37 Only for unlimited polymorphic classes:
38 * _len: An integer(C_SIZE_T) to store the string length when the unlimited
39 polymorphic pointer is used to point to a char array. The '_len'
40 component will be zero when no character array is stored in
43 For each derived type we set up a "vtable" entry, i.e. a structure with the
45 * _hash: A hash value serving as a unique identifier for this type.
46 * _size: The size in bytes of the derived type.
47 * _extends: A pointer to the vtable entry of the parent derived type.
48 * _def_init: A pointer to a default initialized variable of this type.
49 * _copy: A procedure pointer to a copying procedure.
50 * _final: A procedure pointer to a wrapper function, which frees
51 allocatable components and calls FINAL subroutines.
53 After these follow procedure pointer components for the specific
54 type-bound procedures. */
59 #include "coretypes.h"
61 #include "constructor.h"
62 #include "target-memory.h"
64 /* Inserts a derived type component reference in a data reference chain.
65 TS: base type of the ref chain so far, in which we will pick the component
66 REF: the address of the GFC_REF pointer to update
67 NAME: name of the component to insert
68 Note that component insertion makes sense only if we are at the end of
69 the chain (*REF == NULL) or if we are adding a missing "_data" component
70 to access the actual contents of a class object. */
73 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
78 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
80 gfc_find_component (ts
->u
.derived
, name
, true, true, &new_ref
);
82 gfc_get_errors (&wcnt
, &ecnt
);
83 if (ecnt
> 0 && !new_ref
)
85 gcc_assert (new_ref
->u
.c
.component
);
88 new_ref
= new_ref
->next
;
95 /* We need to update the base type in the trailing reference chain to
96 that of the new component. */
98 gcc_assert (strcmp (name
, "_data") == 0);
100 if (new_ref
->next
->type
== REF_COMPONENT
)
101 next
= new_ref
->next
;
102 else if (new_ref
->next
->type
== REF_ARRAY
103 && new_ref
->next
->next
104 && new_ref
->next
->next
->type
== REF_COMPONENT
)
105 next
= new_ref
->next
->next
;
109 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
110 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
111 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
119 /* Tells whether we need to add a "_data" reference to access REF subobject
120 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
121 object accessed by REF is a variable; in other words it is a full object,
125 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
127 /* Only class containers may need the "_data" reference. */
128 if (ts
->type
!= BT_CLASS
)
131 /* Accessing a class container with an array reference is certainly wrong. */
132 if (ref
->type
!= REF_COMPONENT
)
135 /* Accessing the class container's fields is fine. */
136 if (ref
->u
.c
.component
->name
[0] == '_')
139 /* At this point we have a class container with a non class container's field
140 component reference. We don't want to add the "_data" component if we are
141 at the first reference and the symbol's type is an extended derived type.
142 In that case, conv_parent_component_references will do the right thing so
143 it is not absolutely necessary. Omitting it prevents a regression (see
144 class_41.f03) in the interface mapping mechanism. When evaluating string
145 lengths depending on dummy arguments, we create a fake symbol with a type
146 equal to that of the dummy type. However, because of type extension,
147 the backend type (corresponding to the actual argument) can have a
148 different (extended) type. Adding the "_data" component explicitly, using
149 the base type, confuses the gfc_conv_component_ref code which deals with
150 the extended type. */
151 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
154 /* We have a class container with a non class container's field component
155 reference that doesn't fall into the above. */
160 /* Browse through a data reference chain and add the missing "_data" references
161 when a subobject of a class object is accessed without it.
162 Note that it doesn't add the "_data" reference when the class container
163 is the last element in the reference chain. */
166 gfc_fix_class_refs (gfc_expr
*e
)
171 if ((e
->expr_type
!= EXPR_VARIABLE
172 && e
->expr_type
!= EXPR_FUNCTION
)
173 || (e
->expr_type
== EXPR_FUNCTION
174 && e
->value
.function
.isym
!= NULL
))
177 if (e
->expr_type
== EXPR_VARIABLE
)
178 ts
= &e
->symtree
->n
.sym
->ts
;
183 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
184 if (e
->value
.function
.esym
!= NULL
)
185 func
= e
->value
.function
.esym
;
187 func
= e
->symtree
->n
.sym
;
189 if (func
->result
!= NULL
)
190 ts
= &func
->result
->ts
;
195 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
197 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
198 insert_component_ref (ts
, ref
, "_data");
200 if ((*ref
)->type
== REF_COMPONENT
)
201 ts
= &(*ref
)->u
.c
.component
->ts
;
206 /* Insert a reference to the component of the given name.
207 Only to be used with CLASS containers and vtables. */
210 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
213 gfc_ref
**tail
= &(e
->ref
);
214 gfc_ref
*ref
, *next
= NULL
;
215 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
216 while (*tail
!= NULL
)
218 if ((*tail
)->type
== REF_COMPONENT
)
220 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
222 && (*tail
)->next
->type
== REF_ARRAY
223 && (*tail
)->next
->next
== NULL
)
225 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
227 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
229 tail
= &((*tail
)->next
);
231 if (derived
&& derived
->components
&& derived
->components
->next
&&
232 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
233 derived
->components
->next
->ts
.u
.derived
== NULL
)
235 /* Fix up missing vtype. */
236 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
238 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
240 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
243 /* Avoid losing memory. */
244 gfc_free_ref_list (*tail
);
245 c
= gfc_find_component (derived
, name
, true, true, tail
);
248 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
257 /* This is used to add both the _data component reference and an array
258 reference to class expressions. Used in translation of intrinsic
259 array inquiry functions. */
262 gfc_add_class_array_ref (gfc_expr
*e
)
264 int rank
= CLASS_DATA (e
)->as
->rank
;
265 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
267 gfc_add_data_component (e
);
269 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
272 if (ref
->type
!= REF_ARRAY
)
274 ref
->next
= gfc_get_ref ();
276 ref
->type
= REF_ARRAY
;
277 ref
->u
.ar
.type
= AR_FULL
;
283 /* Unfortunately, class array expressions can appear in various conditions;
284 with and without both _data component and an arrayspec. This function
285 deals with that variability. The previous reference to 'ref' is to a
289 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
291 bool no_data
= false;
292 bool with_data
= false;
294 /* An array reference with no _data component. */
295 if (ref
&& ref
->type
== REF_ARRAY
297 && ref
->u
.ar
.type
!= AR_ELEMENT
)
300 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
304 /* Cover cases where _data appears, with or without an array ref. */
305 if (ref
&& ref
->type
== REF_COMPONENT
306 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
314 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
315 && ref
->type
== REF_COMPONENT
316 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
320 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
324 return no_data
|| with_data
;
328 /* Returns true if the expression contains a reference to a class
329 array. Notice that class array elements return false. */
332 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
342 /* Is this a class array object? ie. Is the symbol of type class? */
344 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
345 && CLASS_DATA (e
->symtree
->n
.sym
)
346 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
347 && class_array_ref_detected (e
->ref
, full_array
))
350 /* Or is this a class array component reference? */
351 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
353 if (ref
->type
== REF_COMPONENT
354 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
355 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
356 && class_array_ref_detected (ref
->next
, full_array
))
364 /* Returns true if the expression is a reference to a class
365 scalar. This function is necessary because such expressions
366 can be dressed with a reference to the _data component and so
367 have a type other than BT_CLASS. */
370 gfc_is_class_scalar_expr (gfc_expr
*e
)
377 /* Is this a class object? */
379 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
380 && CLASS_DATA (e
->symtree
->n
.sym
)
381 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
383 || (e
->ref
->type
== REF_COMPONENT
384 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
385 && e
->ref
->next
== NULL
)))
388 /* Or is the final reference BT_CLASS or _data? */
389 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
391 if (ref
->type
== REF_COMPONENT
392 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
393 && CLASS_DATA (ref
->u
.c
.component
)
394 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
395 && (ref
->next
== NULL
396 || (ref
->next
->type
== REF_COMPONENT
397 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
398 && ref
->next
->next
== NULL
)))
406 /* Tells whether the expression E is a reference to a (scalar) class container.
407 Scalar because array class containers usually have an array reference after
408 them, and gfc_fix_class_refs will add the missing "_data" component reference
412 gfc_is_class_container_ref (gfc_expr
*e
)
417 if (e
->expr_type
!= EXPR_VARIABLE
)
418 return e
->ts
.type
== BT_CLASS
;
420 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
425 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
427 if (ref
->type
!= REF_COMPONENT
)
429 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
439 /* Build an initializer for CLASS pointers,
440 initializing the _data component to the init_expr (or NULL) and the _vptr
441 component to the corresponding type (or the declared type, given by ts). */
444 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
448 gfc_symbol
*vtab
= NULL
;
450 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
451 vtab
= gfc_find_vtab (&init_expr
->ts
);
453 vtab
= gfc_find_vtab (ts
);
455 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
456 &ts
->u
.derived
->declared_at
);
459 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
461 gfc_constructor
*ctor
= gfc_constructor_get();
462 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
463 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
464 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
465 ctor
->expr
= gfc_copy_expr (init_expr
);
467 ctor
->expr
= gfc_get_null_expr (NULL
);
468 gfc_constructor_append (&init
->value
.constructor
, ctor
);
475 /* Create a unique string identifier for a derived type, composed of its name
476 and module name. This is used to construct unique names for the class
477 containers and vtab symbols. */
480 get_unique_type_string (gfc_symbol
*derived
)
485 if (derived
->attr
.unlimited_polymorphic
)
488 dt_name
= gfc_dt_upper_string (derived
->name
);
489 len
= strlen (dt_name
) + 2;
490 if (derived
->attr
.unlimited_polymorphic
)
492 string
= XNEWVEC (char, len
);
493 sprintf (string
, "_%s", dt_name
);
495 else if (derived
->module
)
497 string
= XNEWVEC (char, strlen (derived
->module
) + len
);
498 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
500 else if (derived
->ns
->proc_name
)
502 string
= XNEWVEC (char, strlen (derived
->ns
->proc_name
->name
) + len
);
503 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
507 string
= XNEWVEC (char, len
);
508 sprintf (string
, "_%s", dt_name
);
514 /* A relative of 'get_unique_type_string' which makes sure the generated
515 string will not be too long (replacing it by a hash string if needed). */
518 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
520 /* Provide sufficient space to hold "symbol.symbol_symbol". */
522 tmp
= get_unique_type_string (derived
);
523 /* If string is too long, use hash value in hex representation (allow for
524 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
525 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
526 where %d is the (co)rank which can be up to n = 15. */
527 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
529 int h
= gfc_hash_value (derived
);
530 sprintf (string
, "%X", h
);
533 strcpy (string
, tmp
);
538 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
541 gfc_hash_value (gfc_symbol
*sym
)
543 unsigned int hash
= 0;
544 /* Provide sufficient space to hold "symbol.symbol_symbol". */
548 c
= get_unique_type_string (sym
);
551 for (i
= 0; i
< len
; i
++)
552 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
555 /* Return the hash but take the modulus for the sake of module read,
556 even though this slightly increases the chance of collision. */
557 return (hash
% 100000000);
561 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
564 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
566 unsigned int hash
= 0;
567 const char *c
= gfc_typename (ts
, true);
572 for (i
= 0; i
< len
; i
++)
573 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
575 /* Return the hash but take the modulus for the sake of module read,
576 even though this slightly increases the chance of collision. */
577 return (hash
% 100000000);
581 /* Get the _len component from a class/derived object storing a string.
582 For unlimited polymorphic entities a ref to the _data component is available
583 while a ref to the _len component is needed. This routine traverese the
584 ref-chain and strips the last ref to a _data from it replacing it with a
585 ref to the _len component. */
588 gfc_get_len_component (gfc_expr
*e
, int k
)
591 gfc_ref
*ref
, **last
;
593 ptr
= gfc_copy_expr (e
);
595 /* We need to remove the last _data component ref from ptr. */
601 && ref
->type
== REF_COMPONENT
602 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
604 gfc_free_ref_list (ref
);
611 /* And replace if with a ref to the _len component. */
612 gfc_add_len_component (ptr
);
613 if (k
!= ptr
->ts
.kind
)
617 ts
.type
= BT_INTEGER
;
619 gfc_convert_type_warn (ptr
, &ts
, 2, 0);
625 /* Build a polymorphic CLASS entity, using the symbol that comes from
626 build_sym. A CLASS entity is represented by an encapsulating type,
627 which contains the declared type as '_data' component, plus a pointer
628 component '_vptr' which determines the dynamic type. When this CLASS
629 entity is unlimited polymorphic, then also add a component '_len' to
630 store the length of string when that is stored in it. */
633 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
636 char tname
[GFC_MAX_SYMBOL_LEN
+1];
646 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
648 gfc_error ("Assumed size polymorphic objects or components, such "
649 "as that at %C, have not yet been implemented");
654 /* Class container has already been built. */
657 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
658 || attr
->select_type_temporary
|| attr
->associate_var
;
661 /* We cannot build the class container yet. */
664 /* Determine the name of the encapsulating type. */
665 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
670 get_unique_hashed_string (tname
, ts
->u
.derived
);
671 if ((*as
) && attr
->allocatable
)
672 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
673 else if ((*as
) && attr
->pointer
)
674 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
676 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
677 else if (attr
->pointer
)
678 name
= xasprintf ("__class_%s_p", tname
);
679 else if (attr
->allocatable
)
680 name
= xasprintf ("__class_%s_a", tname
);
682 name
= xasprintf ("__class_%s_t", tname
);
684 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
686 /* Find the top-level namespace. */
687 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
692 ns
= ts
->u
.derived
->ns
;
694 gfc_find_symbol (name
, ns
, 0, &fclass
);
698 /* If not there, create a new symbol. */
699 fclass
= gfc_new_symbol (name
, ns
);
700 st
= gfc_new_symtree (&ns
->sym_root
, name
);
702 gfc_set_sym_referenced (fclass
);
704 fclass
->ts
.type
= BT_UNKNOWN
;
705 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
706 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
707 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
708 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
712 /* Add component '_data'. */
713 if (!gfc_add_component (fclass
, "_data", &c
))
716 c
->ts
.type
= BT_DERIVED
;
717 c
->attr
.access
= ACCESS_PRIVATE
;
718 c
->ts
.u
.derived
= ts
->u
.derived
;
719 c
->attr
.class_pointer
= attr
->pointer
;
720 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
721 || attr
->select_type_temporary
;
722 c
->attr
.allocatable
= attr
->allocatable
;
723 c
->attr
.dimension
= attr
->dimension
;
724 c
->attr
.codimension
= attr
->codimension
;
725 c
->attr
.abstract
= fclass
->attr
.abstract
;
727 c
->initializer
= NULL
;
729 /* Add component '_vptr'. */
730 if (!gfc_add_component (fclass
, "_vptr", &c
))
732 c
->ts
.type
= BT_DERIVED
;
733 c
->attr
.access
= ACCESS_PRIVATE
;
736 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
738 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
740 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
742 /* Add component '_len'. Only unlimited polymorphic pointers may
743 have a string assigned to them, i.e., only those need the _len
745 if (!gfc_add_component (fclass
, "_len", &c
))
747 c
->ts
.type
= BT_INTEGER
;
748 c
->ts
.kind
= gfc_charlen_int_kind
;
749 c
->attr
.access
= ACCESS_PRIVATE
;
750 c
->attr
.artificial
= 1;
753 /* Build vtab later. */
754 c
->ts
.u
.derived
= NULL
;
757 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
759 /* Since the extension field is 8 bit wide, we can only have
760 up to 255 extension levels. */
761 if (ts
->u
.derived
->attr
.extension
== 255)
763 gfc_error ("Maximum extension level reached with type %qs at %L",
764 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
768 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
769 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
770 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
773 fclass
->attr
.is_class
= 1;
774 ts
->u
.derived
= fclass
;
775 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
782 /* Add a procedure pointer component to the vtype
783 to represent a specific type-bound procedure. */
786 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
790 if (tb
->non_overridable
&& !tb
->overridden
)
793 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
797 /* Add procedure component. */
798 if (!gfc_add_component (vtype
, name
, &c
))
802 c
->tb
= XCNEW (gfc_typebound_proc
);
805 c
->attr
.procedure
= 1;
806 c
->attr
.proc_pointer
= 1;
807 c
->attr
.flavor
= FL_PROCEDURE
;
808 c
->attr
.access
= ACCESS_PRIVATE
;
809 c
->attr
.external
= 1;
811 c
->attr
.if_source
= IFSRC_IFBODY
;
813 else if (c
->attr
.proc_pointer
&& c
->tb
)
821 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
822 c
->ts
.interface
= ifc
;
824 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
825 c
->attr
.pure
= ifc
->attr
.pure
;
830 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
833 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
839 add_procs_to_declared_vtab1 (st
->left
, vtype
);
842 add_procs_to_declared_vtab1 (st
->right
, vtype
);
844 if (st
->n
.tb
&& !st
->n
.tb
->error
845 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
846 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
850 /* Copy procedure pointers components from the parent type. */
853 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
858 vtab
= gfc_find_derived_vtab (declared
);
860 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
862 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
865 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
870 /* Returns true if any of its nonpointer nonallocatable components or
871 their nonpointer nonallocatable subcomponents has a finalization
875 has_finalizer_component (gfc_symbol
*derived
)
879 for (c
= derived
->components
; c
; c
= c
->next
)
880 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
)
882 if (c
->ts
.u
.derived
->f2k_derived
883 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
886 /* Stop infinite recursion through this function by inhibiting
887 calls when the derived type and that of the component are
889 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
890 && has_finalizer_component (c
->ts
.u
.derived
))
898 comp_is_finalizable (gfc_component
*comp
)
900 if (comp
->attr
.proc_pointer
)
902 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
904 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
905 && (comp
->ts
.u
.derived
->attr
.alloc_comp
906 || has_finalizer_component (comp
->ts
.u
.derived
)
907 || (comp
->ts
.u
.derived
->f2k_derived
908 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
910 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
911 && CLASS_DATA (comp
)->attr
.allocatable
)
918 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
919 neither allocatable nor a pointer but has a finalizer, call it. If it
920 is a nonpointer component with allocatable components or has finalizers, walk
921 them. Either of them is required; other nonallocatables and pointers aren't
923 Note: If the component is allocatable, the DEALLOCATE handling takes care
924 of calling the appropriate finalizers, coarray deregistering, and
925 deallocation of allocatable subcomponents. */
928 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
929 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
930 gfc_namespace
*sub_ns
)
934 gfc_was_finalized
*f
;
936 if (!comp_is_finalizable (comp
))
939 /* If this expression with this component has been finalized
940 already in this namespace, there is nothing to do. */
941 for (f
= sub_ns
->was_finalized
; f
; f
= f
->next
)
943 if (f
->e
== expr
&& f
->c
== comp
)
947 e
= gfc_copy_expr (expr
);
949 e
->ref
= ref
= gfc_get_ref ();
952 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
954 ref
->next
= gfc_get_ref ();
957 ref
->type
= REF_COMPONENT
;
958 ref
->u
.c
.sym
= derived
;
959 ref
->u
.c
.component
= comp
;
962 if (comp
->attr
.dimension
|| comp
->attr
.codimension
963 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
964 && (CLASS_DATA (comp
)->attr
.dimension
965 || CLASS_DATA (comp
)->attr
.codimension
)))
967 ref
->next
= gfc_get_ref ();
968 ref
->next
->type
= REF_ARRAY
;
969 ref
->next
->u
.ar
.dimen
= 0;
970 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
972 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
973 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
976 /* Call DEALLOCATE (comp, stat=ignore). */
977 if (comp
->attr
.allocatable
978 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
979 && CLASS_DATA (comp
)->attr
.allocatable
))
981 gfc_code
*dealloc
, *block
= NULL
;
983 /* Add IF (fini_coarray). */
984 if (comp
->attr
.codimension
985 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
986 && CLASS_DATA (comp
)->attr
.codimension
))
988 block
= gfc_get_code (EXEC_IF
);
991 (*code
)->next
= block
;
992 (*code
) = (*code
)->next
;
997 block
->block
= gfc_get_code (EXEC_IF
);
998 block
= block
->block
;
999 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
1002 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
1004 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
1005 dealloc
->ext
.alloc
.list
->expr
= e
;
1006 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
1008 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
1009 cond
->block
= gfc_get_code (EXEC_IF
);
1010 cond
->block
->expr1
= gfc_get_expr ();
1011 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
1012 cond
->block
->expr1
->where
= gfc_current_locus
;
1013 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
1014 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1015 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1016 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
1017 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
1018 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
1019 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1020 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
1021 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
1022 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
1023 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1024 cond
->block
->next
= dealloc
;
1030 (*code
)->next
= cond
;
1031 (*code
) = (*code
)->next
;
1037 else if (comp
->ts
.type
== BT_DERIVED
1038 && comp
->ts
.u
.derived
->f2k_derived
1039 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1041 /* Call FINAL_WRAPPER (comp); */
1042 gfc_code
*final_wrap
;
1046 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1047 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1048 if (strcmp (c
->name
, "_final") == 0)
1052 final_wrap
= gfc_get_code (EXEC_CALL
);
1053 final_wrap
->symtree
= c
->initializer
->symtree
;
1054 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1055 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1056 final_wrap
->ext
.actual
->expr
= e
;
1060 (*code
)->next
= final_wrap
;
1061 (*code
) = (*code
)->next
;
1064 (*code
) = final_wrap
;
1070 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1071 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1076 /* Record that this was finalized already in this namespace. */
1077 f
= sub_ns
->was_finalized
;
1078 sub_ns
->was_finalized
= XCNEW (gfc_was_finalized
);
1079 sub_ns
->was_finalized
->e
= expr
;
1080 sub_ns
->was_finalized
->c
= comp
;
1081 sub_ns
->was_finalized
->next
= f
;
1085 /* Generate code equivalent to
1086 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1087 + offset, c_ptr), ptr). */
1090 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1091 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1094 gfc_expr
*expr
, *expr2
;
1096 /* C_F_POINTER(). */
1097 block
= gfc_get_code (EXEC_CALL
);
1098 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1099 block
->resolved_sym
= block
->symtree
->n
.sym
;
1100 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1101 block
->resolved_sym
->attr
.intrinsic
= 1;
1102 block
->resolved_sym
->attr
.subroutine
= 1;
1103 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1104 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1105 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1106 gfc_commit_symbol (block
->resolved_sym
);
1108 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1109 block
->ext
.actual
= gfc_get_actual_arglist ();
1110 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1111 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1113 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1115 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1117 /* TRANSFER's first argument: C_LOC (array). */
1118 expr
= gfc_get_expr ();
1119 expr
->expr_type
= EXPR_FUNCTION
;
1120 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1121 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1122 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1123 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1124 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1125 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1126 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1127 expr
->value
.function
.actual
->expr
1128 = gfc_lval_expr_from_sym (array
);
1129 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1130 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1131 expr
->ts
.type
= BT_INTEGER
;
1132 expr
->ts
.kind
= gfc_index_integer_kind
;
1133 expr
->where
= gfc_current_locus
;
1136 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1137 gfc_current_locus
, 3, expr
,
1138 gfc_get_int_expr (gfc_index_integer_kind
,
1140 expr2
->ts
.type
= BT_INTEGER
;
1141 expr2
->ts
.kind
= gfc_index_integer_kind
;
1143 /* <array addr> + <offset>. */
1144 block
->ext
.actual
->expr
= gfc_get_expr ();
1145 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1146 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1147 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1148 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1149 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1150 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1152 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1153 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1154 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1155 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1161 /* Calculates the offset to the (idx+1)th element of an array, taking the
1162 stride into account. It generates the code:
1165 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1167 offset = offset * byte_stride. */
1170 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1171 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1172 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1173 gfc_code
*block
, gfc_namespace
*sub_ns
)
1176 gfc_expr
*expr
, *expr2
;
1179 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1180 block
= block
->next
;
1181 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1182 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1185 iter
= gfc_get_iterator ();
1186 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1187 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1188 iter
->end
= gfc_copy_expr (rank
);
1189 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1190 block
->next
= gfc_get_code (EXEC_DO
);
1191 block
= block
->next
;
1192 block
->ext
.iterator
= iter
;
1193 block
->block
= gfc_get_code (EXEC_DO
);
1195 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1198 /* mod (idx, sizes(idx2)). */
1199 expr
= gfc_lval_expr_from_sym (sizes
);
1200 expr
->ref
= gfc_get_ref ();
1201 expr
->ref
->type
= REF_ARRAY
;
1202 expr
->ref
->u
.ar
.as
= sizes
->as
;
1203 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1204 expr
->ref
->u
.ar
.dimen
= 1;
1205 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1206 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1207 expr
->where
= sizes
->declared_at
;
1209 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1210 gfc_current_locus
, 2,
1211 gfc_lval_expr_from_sym (idx
), expr
);
1214 /* (...) / sizes(idx2-1). */
1215 expr2
= gfc_get_expr ();
1216 expr2
->expr_type
= EXPR_OP
;
1217 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1218 expr2
->value
.op
.op1
= expr
;
1219 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1220 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1221 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1222 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1223 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1224 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1225 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1226 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1227 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1228 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1229 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1230 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1231 = gfc_lval_expr_from_sym (idx2
);
1232 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1233 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1234 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1235 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1236 expr2
->ts
= idx
->ts
;
1237 expr2
->where
= gfc_current_locus
;
1239 /* ... * strides(idx2). */
1240 expr
= gfc_get_expr ();
1241 expr
->expr_type
= EXPR_OP
;
1242 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1243 expr
->value
.op
.op1
= expr2
;
1244 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1245 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1246 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1247 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1248 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1249 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1250 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1251 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1253 expr
->where
= gfc_current_locus
;
1255 /* offset = offset + ... */
1256 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1257 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1258 block
->block
->next
->expr2
= gfc_get_expr ();
1259 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1260 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1261 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1262 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1263 block
->block
->next
->expr2
->ts
= idx
->ts
;
1264 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1266 /* After the loop: offset = offset * byte_stride. */
1267 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1268 block
= block
->next
;
1269 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1270 block
->expr2
= gfc_get_expr ();
1271 block
->expr2
->expr_type
= EXPR_OP
;
1272 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1273 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1274 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1275 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1276 block
->expr2
->where
= gfc_current_locus
;
1281 /* Insert code of the following form:
1284 integer(c_intptr_t) :: i
1286 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1287 && (is_contiguous || !final_rank3->attr.contiguous
1288 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1289 || 0 == STORAGE_SIZE (array)) then
1290 call final_rank3 (array)
1293 integer(c_intptr_t) :: offset, j
1294 type(t) :: tmp(shape (array))
1296 do i = 0, size (array)-1
1297 offset = obtain_offset(i, strides, sizes, byte_stride)
1298 addr = transfer (c_loc (array), addr) + offset
1299 call c_f_pointer (transfer (addr, cptr), ptr)
1301 addr = transfer (c_loc (tmp), addr)
1302 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1303 call c_f_pointer (transfer (addr, cptr), ptr2)
1306 call final_rank3 (tmp)
1312 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1313 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1314 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1316 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1317 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1318 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1319 gfc_namespace
*sub_ns
)
1321 gfc_symbol
*tmp_array
, *ptr2
;
1322 gfc_expr
*size_expr
, *offset2
, *expr
;
1328 block
->next
= gfc_get_code (EXEC_IF
);
1329 block
= block
->next
;
1331 block
->block
= gfc_get_code (EXEC_IF
);
1332 block
= block
->block
;
1334 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1335 size_expr
= gfc_get_expr ();
1336 size_expr
->where
= gfc_current_locus
;
1337 size_expr
->expr_type
= EXPR_OP
;
1338 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1340 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1341 size_expr
->value
.op
.op1
1342 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1343 "storage_size", gfc_current_locus
, 2,
1344 gfc_lval_expr_from_sym (array
),
1345 gfc_get_int_expr (gfc_index_integer_kind
,
1348 /* NUMERIC_STORAGE_SIZE. */
1349 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1350 gfc_character_storage_size
);
1351 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1352 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1354 /* IF condition: (stride == size_expr
1355 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1357 || 0 == size_expr. */
1358 block
->expr1
= gfc_get_expr ();
1359 block
->expr1
->ts
.type
= BT_LOGICAL
;
1360 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1361 block
->expr1
->expr_type
= EXPR_OP
;
1362 block
->expr1
->where
= gfc_current_locus
;
1364 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1366 /* byte_stride == size_expr */
1367 expr
= gfc_get_expr ();
1368 expr
->ts
.type
= BT_LOGICAL
;
1369 expr
->ts
.kind
= gfc_default_logical_kind
;
1370 expr
->expr_type
= EXPR_OP
;
1371 expr
->where
= gfc_current_locus
;
1372 expr
->value
.op
.op
= INTRINSIC_EQ
;
1374 = gfc_lval_expr_from_sym (byte_stride
);
1375 expr
->value
.op
.op2
= size_expr
;
1377 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1378 add is_contiguous check. */
1380 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1381 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1384 expr2
= gfc_get_expr ();
1385 expr2
->ts
.type
= BT_LOGICAL
;
1386 expr2
->ts
.kind
= gfc_default_logical_kind
;
1387 expr2
->expr_type
= EXPR_OP
;
1388 expr2
->where
= gfc_current_locus
;
1389 expr2
->value
.op
.op
= INTRINSIC_AND
;
1390 expr2
->value
.op
.op1
= expr
;
1391 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1395 block
->expr1
->value
.op
.op1
= expr
;
1397 /* 0 == size_expr */
1398 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1399 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1400 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1401 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1402 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1403 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1404 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1405 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1406 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1408 /* IF body: call final subroutine. */
1409 block
->next
= gfc_get_code (EXEC_CALL
);
1410 block
->next
->symtree
= fini
->proc_tree
;
1411 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1412 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1413 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1414 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1415 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1419 block
->block
= gfc_get_code (EXEC_IF
);
1420 block
= block
->block
;
1422 /* BLOCK ... END BLOCK. */
1423 block
->next
= gfc_get_code (EXEC_BLOCK
);
1424 block
= block
->next
;
1426 ns
= gfc_build_block_ns (sub_ns
);
1427 block
->ext
.block
.ns
= ns
;
1428 block
->ext
.block
.assoc
= NULL
;
1430 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1431 ptr2
->ts
.type
= BT_DERIVED
;
1432 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1433 ptr2
->attr
.flavor
= FL_VARIABLE
;
1434 ptr2
->attr
.pointer
= 1;
1435 ptr2
->attr
.artificial
= 1;
1436 gfc_set_sym_referenced (ptr2
);
1437 gfc_commit_symbol (ptr2
);
1439 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1440 tmp_array
->ts
.type
= BT_DERIVED
;
1441 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1442 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1443 tmp_array
->attr
.dimension
= 1;
1444 tmp_array
->attr
.artificial
= 1;
1445 tmp_array
->as
= gfc_get_array_spec();
1446 tmp_array
->attr
.intent
= INTENT_INOUT
;
1447 tmp_array
->as
->type
= AS_EXPLICIT
;
1448 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1450 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1452 gfc_expr
*shape_expr
;
1453 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1455 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1457 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1458 gfc_current_locus
, 3,
1459 gfc_lval_expr_from_sym (array
),
1460 gfc_get_int_expr (gfc_default_integer_kind
,
1462 gfc_get_int_expr (gfc_default_integer_kind
,
1464 gfc_index_integer_kind
));
1465 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1466 tmp_array
->as
->upper
[i
] = shape_expr
;
1468 gfc_set_sym_referenced (tmp_array
);
1469 gfc_commit_symbol (tmp_array
);
1472 iter
= gfc_get_iterator ();
1473 iter
->var
= gfc_lval_expr_from_sym (idx
);
1474 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1475 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1476 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1478 block
= gfc_get_code (EXEC_DO
);
1480 block
->ext
.iterator
= iter
;
1481 block
->block
= gfc_get_code (EXEC_DO
);
1483 /* Offset calculation for the new array: idx * size of type (in bytes). */
1484 offset2
= gfc_get_expr ();
1485 offset2
->expr_type
= EXPR_OP
;
1486 offset2
->where
= gfc_current_locus
;
1487 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1488 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1489 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1490 offset2
->ts
= byte_stride
->ts
;
1492 /* Offset calculation of "array". */
1493 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1494 byte_stride
, rank
, block
->block
, sub_ns
);
1497 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1498 + idx * stride, c_ptr), ptr). */
1499 block2
->next
= finalization_scalarizer (array
, ptr
,
1500 gfc_lval_expr_from_sym (offset
),
1502 block2
= block2
->next
;
1503 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1504 block2
= block2
->next
;
1507 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1508 block2
= block2
->next
;
1509 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1510 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1512 /* Call now the user's final subroutine. */
1513 block
->next
= gfc_get_code (EXEC_CALL
);
1514 block
= block
->next
;
1515 block
->symtree
= fini
->proc_tree
;
1516 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1517 block
->ext
.actual
= gfc_get_actual_arglist ();
1518 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1520 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1526 iter
= gfc_get_iterator ();
1527 iter
->var
= gfc_lval_expr_from_sym (idx
);
1528 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1529 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1530 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1532 block
->next
= gfc_get_code (EXEC_DO
);
1533 block
= block
->next
;
1534 block
->ext
.iterator
= iter
;
1535 block
->block
= gfc_get_code (EXEC_DO
);
1537 /* Offset calculation of "array". */
1538 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1539 byte_stride
, rank
, block
->block
, sub_ns
);
1542 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1543 + offset, c_ptr), ptr). */
1544 block2
->next
= finalization_scalarizer (array
, ptr
,
1545 gfc_lval_expr_from_sym (offset
),
1547 block2
= block2
->next
;
1548 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1549 gfc_copy_expr (offset2
), sub_ns
);
1550 block2
= block2
->next
;
1553 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1554 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1555 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1559 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1560 derived type "derived". The function first calls the approriate FINAL
1561 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1562 components (but not the inherited ones). Last, it calls the wrapper
1563 subroutine of the parent. The generated wrapper procedure takes as argument
1564 an assumed-rank array.
1565 If neither allocatable components nor FINAL subroutines exists, the vtab
1566 will contain a NULL pointer.
1567 The generated function has the form
1568 _final(assumed-rank array, stride, skip_corarray)
1569 where the array has to be contiguous (except of the lowest dimension). The
1570 stride (in bytes) is used to allow different sizes for ancestor types by
1571 skipping over the additionally added components in the scalarizer. If
1572 "fini_coarray" is false, coarray components are not finalized to allow for
1573 the correct semantic with intrinsic assignment. */
1576 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1577 const char *tname
, gfc_component
*vtab_final
)
1579 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1580 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1581 gfc_component
*comp
;
1582 gfc_namespace
*sub_ns
;
1583 gfc_code
*last_code
, *block
;
1585 bool finalizable_comp
= false;
1586 bool expr_null_wrapper
= false;
1587 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1590 if (derived
->attr
.unlimited_polymorphic
)
1592 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1596 /* Search for the ancestor's finalizers. */
1597 if (derived
->attr
.extension
&& derived
->components
1598 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1599 || has_finalizer_component (derived
)))
1602 gfc_component
*comp
;
1604 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1605 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1606 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1608 ancestor_wrapper
= comp
->initializer
;
1613 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1614 components: Return a NULL() expression; we defer this a bit to have
1615 an interface declaration. */
1616 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1617 && !derived
->attr
.alloc_comp
1618 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1619 && !has_finalizer_component (derived
))
1620 expr_null_wrapper
= true;
1622 /* Check whether there are new allocatable components. */
1623 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1625 if (comp
== derived
->components
&& derived
->attr
.extension
1626 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1629 finalizable_comp
|= comp_is_finalizable (comp
);
1632 /* If there is no new finalizer and no new allocatable, return with
1633 an expr to the ancestor's one. */
1634 if (!expr_null_wrapper
&& !finalizable_comp
1635 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1637 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1638 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1639 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1640 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1644 /* We now create a wrapper, which does the following:
1645 1. Call the suitable finalization subroutine for this type
1646 2. Loop over all noninherited allocatable components and noninherited
1647 components with allocatable components and DEALLOCATE those; this will
1648 take care of finalizers, coarray deregistering and allocatable
1650 3. Call the ancestor's finalizer. */
1652 /* Declare the wrapper function; it takes an assumed-rank array
1653 and a VALUE logical as arguments. */
1655 /* Set up the namespace. */
1656 sub_ns
= gfc_get_namespace (ns
, 0);
1657 sub_ns
->sibling
= ns
->contained
;
1658 if (!expr_null_wrapper
)
1659 ns
->contained
= sub_ns
;
1660 sub_ns
->resolved
= 1;
1662 /* Set up the procedure symbol. */
1663 name
= xasprintf ("__final_%s", tname
);
1664 gfc_get_symbol (name
, sub_ns
, &final
);
1665 sub_ns
->proc_name
= final
;
1666 final
->attr
.flavor
= FL_PROCEDURE
;
1667 final
->attr
.function
= 1;
1668 final
->attr
.pure
= 0;
1669 final
->attr
.recursive
= 1;
1670 final
->result
= final
;
1671 final
->ts
.type
= BT_INTEGER
;
1673 final
->attr
.artificial
= 1;
1674 final
->attr
.always_explicit
= 1;
1675 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1676 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1677 final
->module
= ns
->proc_name
->name
;
1678 gfc_set_sym_referenced (final
);
1679 gfc_commit_symbol (final
);
1681 /* Set up formal argument. */
1682 gfc_get_symbol ("array", sub_ns
, &array
);
1683 array
->ts
.type
= BT_DERIVED
;
1684 array
->ts
.u
.derived
= derived
;
1685 array
->attr
.flavor
= FL_VARIABLE
;
1686 array
->attr
.dummy
= 1;
1687 array
->attr
.contiguous
= 1;
1688 array
->attr
.dimension
= 1;
1689 array
->attr
.artificial
= 1;
1690 array
->as
= gfc_get_array_spec();
1691 array
->as
->type
= AS_ASSUMED_RANK
;
1692 array
->as
->rank
= -1;
1693 array
->attr
.intent
= INTENT_INOUT
;
1694 gfc_set_sym_referenced (array
);
1695 final
->formal
= gfc_get_formal_arglist ();
1696 final
->formal
->sym
= array
;
1697 gfc_commit_symbol (array
);
1699 /* Set up formal argument. */
1700 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1701 byte_stride
->ts
.type
= BT_INTEGER
;
1702 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1703 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1704 byte_stride
->attr
.dummy
= 1;
1705 byte_stride
->attr
.value
= 1;
1706 byte_stride
->attr
.artificial
= 1;
1707 gfc_set_sym_referenced (byte_stride
);
1708 final
->formal
->next
= gfc_get_formal_arglist ();
1709 final
->formal
->next
->sym
= byte_stride
;
1710 gfc_commit_symbol (byte_stride
);
1712 /* Set up formal argument. */
1713 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1714 fini_coarray
->ts
.type
= BT_LOGICAL
;
1715 fini_coarray
->ts
.kind
= 1;
1716 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1717 fini_coarray
->attr
.dummy
= 1;
1718 fini_coarray
->attr
.value
= 1;
1719 fini_coarray
->attr
.artificial
= 1;
1720 gfc_set_sym_referenced (fini_coarray
);
1721 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1722 final
->formal
->next
->next
->sym
= fini_coarray
;
1723 gfc_commit_symbol (fini_coarray
);
1725 /* Return with a NULL() expression but with an interface which has
1726 the formal arguments. */
1727 if (expr_null_wrapper
)
1729 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1730 vtab_final
->ts
.interface
= final
;
1734 /* Local variables. */
1736 gfc_get_symbol ("idx", sub_ns
, &idx
);
1737 idx
->ts
.type
= BT_INTEGER
;
1738 idx
->ts
.kind
= gfc_index_integer_kind
;
1739 idx
->attr
.flavor
= FL_VARIABLE
;
1740 idx
->attr
.artificial
= 1;
1741 gfc_set_sym_referenced (idx
);
1742 gfc_commit_symbol (idx
);
1744 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1745 idx2
->ts
.type
= BT_INTEGER
;
1746 idx2
->ts
.kind
= gfc_index_integer_kind
;
1747 idx2
->attr
.flavor
= FL_VARIABLE
;
1748 idx2
->attr
.artificial
= 1;
1749 gfc_set_sym_referenced (idx2
);
1750 gfc_commit_symbol (idx2
);
1752 gfc_get_symbol ("offset", sub_ns
, &offset
);
1753 offset
->ts
.type
= BT_INTEGER
;
1754 offset
->ts
.kind
= gfc_index_integer_kind
;
1755 offset
->attr
.flavor
= FL_VARIABLE
;
1756 offset
->attr
.artificial
= 1;
1757 gfc_set_sym_referenced (offset
);
1758 gfc_commit_symbol (offset
);
1760 /* Create RANK expression. */
1761 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1762 gfc_current_locus
, 1,
1763 gfc_lval_expr_from_sym (array
));
1764 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1765 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1767 /* Create is_contiguous variable. */
1768 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1769 is_contiguous
->ts
.type
= BT_LOGICAL
;
1770 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1771 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1772 is_contiguous
->attr
.artificial
= 1;
1773 gfc_set_sym_referenced (is_contiguous
);
1774 gfc_commit_symbol (is_contiguous
);
1776 /* Create "sizes(0..rank)" variable, which contains the multiplied
1777 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1778 sizes(2) = sizes(1) * extent(dim=2) etc. */
1779 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1780 sizes
->ts
.type
= BT_INTEGER
;
1781 sizes
->ts
.kind
= gfc_index_integer_kind
;
1782 sizes
->attr
.flavor
= FL_VARIABLE
;
1783 sizes
->attr
.dimension
= 1;
1784 sizes
->attr
.artificial
= 1;
1785 sizes
->as
= gfc_get_array_spec();
1786 sizes
->attr
.intent
= INTENT_INOUT
;
1787 sizes
->as
->type
= AS_EXPLICIT
;
1788 sizes
->as
->rank
= 1;
1789 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1790 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1791 gfc_set_sym_referenced (sizes
);
1792 gfc_commit_symbol (sizes
);
1794 /* Create "strides(1..rank)" variable, which contains the strides per
1796 gfc_get_symbol ("strides", sub_ns
, &strides
);
1797 strides
->ts
.type
= BT_INTEGER
;
1798 strides
->ts
.kind
= gfc_index_integer_kind
;
1799 strides
->attr
.flavor
= FL_VARIABLE
;
1800 strides
->attr
.dimension
= 1;
1801 strides
->attr
.artificial
= 1;
1802 strides
->as
= gfc_get_array_spec();
1803 strides
->attr
.intent
= INTENT_INOUT
;
1804 strides
->as
->type
= AS_EXPLICIT
;
1805 strides
->as
->rank
= 1;
1806 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1807 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1808 gfc_set_sym_referenced (strides
);
1809 gfc_commit_symbol (strides
);
1812 /* Set return value to 0. */
1813 last_code
= gfc_get_code (EXEC_ASSIGN
);
1814 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1815 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1816 sub_ns
->code
= last_code
;
1818 /* Set: is_contiguous = .true. */
1819 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1820 last_code
= last_code
->next
;
1821 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1822 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1823 &gfc_current_locus
, true);
1825 /* Set: sizes(0) = 1. */
1826 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1827 last_code
= last_code
->next
;
1828 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1829 last_code
->expr1
->ref
= gfc_get_ref ();
1830 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1831 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1832 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1833 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1834 last_code
->expr1
->ref
->u
.ar
.start
[0]
1835 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1836 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1837 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1841 strides(idx) = _F._stride (array, dim=idx)
1842 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1843 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1847 iter
= gfc_get_iterator ();
1848 iter
->var
= gfc_lval_expr_from_sym (idx
);
1849 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1850 iter
->end
= gfc_copy_expr (rank
);
1851 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1852 last_code
->next
= gfc_get_code (EXEC_DO
);
1853 last_code
= last_code
->next
;
1854 last_code
->ext
.iterator
= iter
;
1855 last_code
->block
= gfc_get_code (EXEC_DO
);
1857 /* strides(idx) = _F._stride(array,dim=idx). */
1858 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1859 block
= last_code
->block
->next
;
1861 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1862 block
->expr1
->ref
= gfc_get_ref ();
1863 block
->expr1
->ref
->type
= REF_ARRAY
;
1864 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1865 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1866 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1867 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1868 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1870 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1871 gfc_current_locus
, 2,
1872 gfc_lval_expr_from_sym (array
),
1873 gfc_lval_expr_from_sym (idx
));
1875 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1876 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1877 block
= block
->next
;
1879 /* sizes(idx) = ... */
1880 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1881 block
->expr1
->ref
= gfc_get_ref ();
1882 block
->expr1
->ref
->type
= REF_ARRAY
;
1883 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1884 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1885 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1886 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1887 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1889 block
->expr2
= gfc_get_expr ();
1890 block
->expr2
->expr_type
= EXPR_OP
;
1891 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1892 block
->expr2
->where
= gfc_current_locus
;
1895 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1896 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1897 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1898 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1899 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1900 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1901 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1902 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1903 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1904 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1905 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1906 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1907 = gfc_lval_expr_from_sym (idx
);
1908 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1909 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1910 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1911 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1913 /* size(array, dim=idx, kind=index_kind). */
1914 block
->expr2
->value
.op
.op2
1915 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1916 gfc_current_locus
, 3,
1917 gfc_lval_expr_from_sym (array
),
1918 gfc_lval_expr_from_sym (idx
),
1919 gfc_get_int_expr (gfc_index_integer_kind
,
1921 gfc_index_integer_kind
));
1922 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1923 block
->expr2
->ts
= idx
->ts
;
1925 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1926 block
->next
= gfc_get_code (EXEC_IF
);
1927 block
= block
->next
;
1929 block
->block
= gfc_get_code (EXEC_IF
);
1930 block
= block
->block
;
1932 /* if condition: strides(idx) /= sizes(idx-1). */
1933 block
->expr1
= gfc_get_expr ();
1934 block
->expr1
->ts
.type
= BT_LOGICAL
;
1935 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1936 block
->expr1
->expr_type
= EXPR_OP
;
1937 block
->expr1
->where
= gfc_current_locus
;
1938 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1940 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1941 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1942 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1943 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1944 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1945 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1946 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1947 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1949 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1950 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1951 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1952 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1953 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1954 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1955 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1956 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1957 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1958 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1959 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1960 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1961 = gfc_lval_expr_from_sym (idx
);
1962 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1963 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1964 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1965 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1967 /* if body: is_contiguous = .false. */
1968 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1969 block
= block
->next
;
1970 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1971 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1972 &gfc_current_locus
, false);
1974 /* Obtain the size (number of elements) of "array" MINUS ONE,
1975 which is used in the scalarization. */
1976 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1977 nelem
->ts
.type
= BT_INTEGER
;
1978 nelem
->ts
.kind
= gfc_index_integer_kind
;
1979 nelem
->attr
.flavor
= FL_VARIABLE
;
1980 nelem
->attr
.artificial
= 1;
1981 gfc_set_sym_referenced (nelem
);
1982 gfc_commit_symbol (nelem
);
1984 /* nelem = sizes (rank) - 1. */
1985 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1986 last_code
= last_code
->next
;
1988 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1990 last_code
->expr2
= gfc_get_expr ();
1991 last_code
->expr2
->expr_type
= EXPR_OP
;
1992 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1993 last_code
->expr2
->value
.op
.op2
1994 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1995 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1996 last_code
->expr2
->where
= gfc_current_locus
;
1998 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1999 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2000 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2001 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2002 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2003 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2004 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
2005 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2007 /* Call final subroutines. We now generate code like:
2009 integer, pointer :: ptr
2011 integer(c_intptr_t) :: i, addr
2013 select case (rank (array))
2015 ! If needed, the array is packed
2016 call final_rank3 (array)
2018 do i = 0, size (array)-1
2019 addr = transfer (c_loc (array), addr) + i * stride
2020 call c_f_pointer (transfer (addr, cptr), ptr)
2021 call elemental_final (ptr)
2025 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2027 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2029 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
2030 ptr
->ts
.type
= BT_DERIVED
;
2031 ptr
->ts
.u
.derived
= derived
;
2032 ptr
->attr
.flavor
= FL_VARIABLE
;
2033 ptr
->attr
.pointer
= 1;
2034 ptr
->attr
.artificial
= 1;
2035 gfc_set_sym_referenced (ptr
);
2036 gfc_commit_symbol (ptr
);
2038 /* SELECT CASE (RANK (array)). */
2039 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2040 last_code
= last_code
->next
;
2041 last_code
->expr1
= gfc_copy_expr (rank
);
2044 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
2046 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2047 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2053 /* CASE (fini_rank). */
2056 block
->block
= gfc_get_code (EXEC_SELECT
);
2057 block
= block
->block
;
2061 block
= gfc_get_code (EXEC_SELECT
);
2062 last_code
->block
= block
;
2064 block
->ext
.block
.case_list
= gfc_get_case ();
2065 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2066 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2067 block
->ext
.block
.case_list
->low
2068 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2069 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2071 block
->ext
.block
.case_list
->low
2072 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2073 block
->ext
.block
.case_list
->high
2074 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2076 /* CALL fini_rank (array) - possibly with packing. */
2077 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2078 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2079 idx
, ptr
, nelem
, strides
,
2080 sizes
, idx2
, offset
, is_contiguous
,
2084 block
->next
= gfc_get_code (EXEC_CALL
);
2085 block
->next
->symtree
= fini
->proc_tree
;
2086 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2087 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2088 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2092 /* Elemental call - scalarized. */
2098 block
->block
= gfc_get_code (EXEC_SELECT
);
2099 block
= block
->block
;
2103 block
= gfc_get_code (EXEC_SELECT
);
2104 last_code
->block
= block
;
2106 block
->ext
.block
.case_list
= gfc_get_case ();
2109 iter
= gfc_get_iterator ();
2110 iter
->var
= gfc_lval_expr_from_sym (idx
);
2111 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2112 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2113 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2114 block
->next
= gfc_get_code (EXEC_DO
);
2115 block
= block
->next
;
2116 block
->ext
.iterator
= iter
;
2117 block
->block
= gfc_get_code (EXEC_DO
);
2119 /* Offset calculation. */
2120 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2121 byte_stride
, rank
, block
->block
,
2125 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2126 + offset, c_ptr), ptr). */
2128 = finalization_scalarizer (array
, ptr
,
2129 gfc_lval_expr_from_sym (offset
),
2131 block
= block
->next
;
2133 /* CALL final_elemental (array). */
2134 block
->next
= gfc_get_code (EXEC_CALL
);
2135 block
= block
->next
;
2136 block
->symtree
= fini_elem
->proc_tree
;
2137 block
->resolved_sym
= fini_elem
->proc_sym
;
2138 block
->ext
.actual
= gfc_get_actual_arglist ();
2139 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2143 /* Finalize and deallocate allocatable components. The same manual
2144 scalarization is used as above. */
2146 if (finalizable_comp
)
2149 gfc_code
*block
= NULL
;
2153 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2154 ptr
->ts
.type
= BT_DERIVED
;
2155 ptr
->ts
.u
.derived
= derived
;
2156 ptr
->attr
.flavor
= FL_VARIABLE
;
2157 ptr
->attr
.pointer
= 1;
2158 ptr
->attr
.artificial
= 1;
2159 gfc_set_sym_referenced (ptr
);
2160 gfc_commit_symbol (ptr
);
2163 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2164 stat
->attr
.flavor
= FL_VARIABLE
;
2165 stat
->attr
.artificial
= 1;
2166 stat
->ts
.type
= BT_INTEGER
;
2167 stat
->ts
.kind
= gfc_default_integer_kind
;
2168 gfc_set_sym_referenced (stat
);
2169 gfc_commit_symbol (stat
);
2172 iter
= gfc_get_iterator ();
2173 iter
->var
= gfc_lval_expr_from_sym (idx
);
2174 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2175 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2176 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2177 last_code
->next
= gfc_get_code (EXEC_DO
);
2178 last_code
= last_code
->next
;
2179 last_code
->ext
.iterator
= iter
;
2180 last_code
->block
= gfc_get_code (EXEC_DO
);
2182 /* Offset calculation. */
2183 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2184 byte_stride
, rank
, last_code
->block
,
2188 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2189 + idx * stride, c_ptr), ptr). */
2190 block
->next
= finalization_scalarizer (array
, ptr
,
2191 gfc_lval_expr_from_sym(offset
),
2193 block
= block
->next
;
2195 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2197 if (comp
== derived
->components
&& derived
->attr
.extension
2198 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2201 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2202 stat
, fini_coarray
, &block
, sub_ns
);
2203 if (!last_code
->block
->next
)
2204 last_code
->block
->next
= block
;
2209 /* Call the finalizer of the ancestor. */
2210 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2212 last_code
->next
= gfc_get_code (EXEC_CALL
);
2213 last_code
= last_code
->next
;
2214 last_code
->symtree
= ancestor_wrapper
->symtree
;
2215 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2217 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2218 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2219 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2220 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2221 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2222 last_code
->ext
.actual
->next
->next
->expr
2223 = gfc_lval_expr_from_sym (fini_coarray
);
2226 gfc_free_expr (rank
);
2227 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2228 vtab_final
->ts
.interface
= final
;
2233 /* Add procedure pointers for all type-bound procedures to a vtab. */
2236 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2238 gfc_symbol
* super_type
;
2240 super_type
= gfc_get_derived_super_type (derived
);
2242 if (super_type
&& (super_type
!= derived
))
2244 /* Make sure that the PPCs appear in the same order as in the parent. */
2245 copy_vtab_proc_comps (super_type
, vtype
);
2246 /* Only needed to get the PPC initializers right. */
2247 add_procs_to_declared_vtab (super_type
, vtype
);
2250 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2251 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2253 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2254 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2258 /* Find or generate the symbol for a derived type's vtab. */
2261 gfc_find_derived_vtab (gfc_symbol
*derived
)
2264 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2265 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2266 gfc_gsymbol
*gsym
= NULL
;
2267 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2269 if (derived
->attr
.pdt_template
)
2272 /* Find the top-level namespace. */
2273 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2277 /* If the type is a class container, use the underlying derived type. */
2278 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2279 derived
= gfc_get_derived_super_type (derived
);
2287 /* Find the gsymbol for the module of use associated derived types. */
2288 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2289 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2290 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2294 /* Work in the gsymbol namespace if the top-level namespace is a module.
2295 This ensures that the vtable is unique, which is required since we use
2296 its address in SELECT TYPE. */
2297 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2298 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2303 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2306 get_unique_hashed_string (tname
, derived
);
2307 name
= xasprintf ("__vtab_%s", tname
);
2309 /* Look for the vtab symbol in various namespaces. */
2310 if (gsym
&& gsym
->ns
)
2312 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2317 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2319 gfc_find_symbol (name
, ns
, 0, &vtab
);
2321 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2325 gfc_get_symbol (name
, ns
, &vtab
);
2326 vtab
->ts
.type
= BT_DERIVED
;
2327 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2328 &gfc_current_locus
))
2330 vtab
->attr
.target
= 1;
2331 vtab
->attr
.save
= SAVE_IMPLICIT
;
2332 vtab
->attr
.vtab
= 1;
2333 vtab
->attr
.access
= ACCESS_PUBLIC
;
2334 gfc_set_sym_referenced (vtab
);
2335 name
= xasprintf ("__vtype_%s", tname
);
2337 gfc_find_symbol (name
, ns
, 0, &vtype
);
2341 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2344 /* Is this a derived type with recursive allocatable
2346 c
= (derived
->attr
.unlimited_polymorphic
2347 || derived
->attr
.abstract
) ?
2348 NULL
: derived
->components
;
2349 for (; c
; c
= c
->next
)
2350 if (c
->ts
.type
== BT_DERIVED
2351 && c
->ts
.u
.derived
== derived
)
2357 gfc_get_symbol (name
, ns
, &vtype
);
2358 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2359 &gfc_current_locus
))
2361 vtype
->attr
.access
= ACCESS_PUBLIC
;
2362 vtype
->attr
.vtype
= 1;
2363 gfc_set_sym_referenced (vtype
);
2365 /* Add component '_hash'. */
2366 if (!gfc_add_component (vtype
, "_hash", &c
))
2368 c
->ts
.type
= BT_INTEGER
;
2370 c
->attr
.access
= ACCESS_PRIVATE
;
2371 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2372 NULL
, derived
->hash_value
);
2374 /* Add component '_size'. */
2375 if (!gfc_add_component (vtype
, "_size", &c
))
2377 c
->ts
.type
= BT_INTEGER
;
2378 c
->ts
.kind
= gfc_size_kind
;
2379 c
->attr
.access
= ACCESS_PRIVATE
;
2380 /* Remember the derived type in ts.u.derived,
2381 so that the correct initializer can be set later on
2382 (in gfc_conv_structure). */
2383 c
->ts
.u
.derived
= derived
;
2384 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2387 /* Add component _extends. */
2388 if (!gfc_add_component (vtype
, "_extends", &c
))
2390 c
->attr
.pointer
= 1;
2391 c
->attr
.access
= ACCESS_PRIVATE
;
2392 if (!derived
->attr
.unlimited_polymorphic
)
2393 parent
= gfc_get_derived_super_type (derived
);
2399 parent_vtab
= gfc_find_derived_vtab (parent
);
2400 c
->ts
.type
= BT_DERIVED
;
2401 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2402 c
->initializer
= gfc_get_expr ();
2403 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2404 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2405 0, &c
->initializer
->symtree
);
2409 c
->ts
.type
= BT_DERIVED
;
2410 c
->ts
.u
.derived
= vtype
;
2411 c
->initializer
= gfc_get_null_expr (NULL
);
2414 if (!derived
->attr
.unlimited_polymorphic
2415 && derived
->components
== NULL
2416 && !derived
->attr
.zero_comp
)
2418 /* At this point an error must have occurred.
2419 Prevent further errors on the vtype components. */
2424 /* Add component _def_init. */
2425 if (!gfc_add_component (vtype
, "_def_init", &c
))
2427 c
->attr
.pointer
= 1;
2428 c
->attr
.artificial
= 1;
2429 c
->attr
.access
= ACCESS_PRIVATE
;
2430 c
->ts
.type
= BT_DERIVED
;
2431 c
->ts
.u
.derived
= derived
;
2432 if (derived
->attr
.unlimited_polymorphic
2433 || derived
->attr
.abstract
)
2434 c
->initializer
= gfc_get_null_expr (NULL
);
2437 /* Construct default initialization variable. */
2438 name
= xasprintf ("__def_init_%s", tname
);
2439 gfc_get_symbol (name
, ns
, &def_init
);
2440 def_init
->attr
.target
= 1;
2441 def_init
->attr
.artificial
= 1;
2442 def_init
->attr
.save
= SAVE_IMPLICIT
;
2443 def_init
->attr
.access
= ACCESS_PUBLIC
;
2444 def_init
->attr
.flavor
= FL_VARIABLE
;
2445 gfc_set_sym_referenced (def_init
);
2446 def_init
->ts
.type
= BT_DERIVED
;
2447 def_init
->ts
.u
.derived
= derived
;
2448 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2450 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2453 /* Add component _copy. */
2454 if (!gfc_add_component (vtype
, "_copy", &c
))
2456 c
->attr
.proc_pointer
= 1;
2457 c
->attr
.access
= ACCESS_PRIVATE
;
2458 c
->tb
= XCNEW (gfc_typebound_proc
);
2460 if (derived
->attr
.unlimited_polymorphic
2461 || derived
->attr
.abstract
)
2462 c
->initializer
= gfc_get_null_expr (NULL
);
2465 /* Set up namespace. */
2466 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2467 sub_ns
->sibling
= ns
->contained
;
2468 ns
->contained
= sub_ns
;
2469 sub_ns
->resolved
= 1;
2470 /* Set up procedure symbol. */
2471 name
= xasprintf ("__copy_%s", tname
);
2472 gfc_get_symbol (name
, sub_ns
, ©
);
2473 sub_ns
->proc_name
= copy
;
2474 copy
->attr
.flavor
= FL_PROCEDURE
;
2475 copy
->attr
.subroutine
= 1;
2476 copy
->attr
.pure
= 1;
2477 copy
->attr
.artificial
= 1;
2478 copy
->attr
.if_source
= IFSRC_DECL
;
2479 /* This is elemental so that arrays are automatically
2480 treated correctly by the scalarizer. */
2481 copy
->attr
.elemental
= 1;
2482 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2483 copy
->module
= ns
->proc_name
->name
;
2484 gfc_set_sym_referenced (copy
);
2485 /* Set up formal arguments. */
2486 gfc_get_symbol ("src", sub_ns
, &src
);
2487 src
->ts
.type
= BT_DERIVED
;
2488 src
->ts
.u
.derived
= derived
;
2489 src
->attr
.flavor
= FL_VARIABLE
;
2490 src
->attr
.dummy
= 1;
2491 src
->attr
.artificial
= 1;
2492 src
->attr
.intent
= INTENT_IN
;
2493 gfc_set_sym_referenced (src
);
2494 copy
->formal
= gfc_get_formal_arglist ();
2495 copy
->formal
->sym
= src
;
2496 gfc_get_symbol ("dst", sub_ns
, &dst
);
2497 dst
->ts
.type
= BT_DERIVED
;
2498 dst
->ts
.u
.derived
= derived
;
2499 dst
->attr
.flavor
= FL_VARIABLE
;
2500 dst
->attr
.dummy
= 1;
2501 dst
->attr
.artificial
= 1;
2502 dst
->attr
.intent
= INTENT_INOUT
;
2503 gfc_set_sym_referenced (dst
);
2504 copy
->formal
->next
= gfc_get_formal_arglist ();
2505 copy
->formal
->next
->sym
= dst
;
2507 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2508 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2509 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2510 /* Set initializer. */
2511 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2512 c
->ts
.interface
= copy
;
2515 /* Add component _final, which contains a procedure pointer to
2516 a wrapper which handles both the freeing of allocatable
2517 components and the calls to finalization subroutines.
2518 Note: The actual wrapper function can only be generated
2519 at resolution time. */
2520 if (!gfc_add_component (vtype
, "_final", &c
))
2522 c
->attr
.proc_pointer
= 1;
2523 c
->attr
.access
= ACCESS_PRIVATE
;
2524 c
->attr
.artificial
= 1;
2525 c
->tb
= XCNEW (gfc_typebound_proc
);
2527 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2529 /* Add component _deallocate. */
2530 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2532 c
->attr
.proc_pointer
= 1;
2533 c
->attr
.access
= ACCESS_PRIVATE
;
2534 c
->tb
= XCNEW (gfc_typebound_proc
);
2536 if (derived
->attr
.unlimited_polymorphic
2537 || derived
->attr
.abstract
2539 c
->initializer
= gfc_get_null_expr (NULL
);
2542 /* Set up namespace. */
2543 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2545 sub_ns
->sibling
= ns
->contained
;
2546 ns
->contained
= sub_ns
;
2547 sub_ns
->resolved
= 1;
2548 /* Set up procedure symbol. */
2549 name
= xasprintf ("__deallocate_%s", tname
);
2550 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2551 sub_ns
->proc_name
= dealloc
;
2552 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2553 dealloc
->attr
.subroutine
= 1;
2554 dealloc
->attr
.pure
= 1;
2555 dealloc
->attr
.artificial
= 1;
2556 dealloc
->attr
.if_source
= IFSRC_DECL
;
2558 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2559 dealloc
->module
= ns
->proc_name
->name
;
2560 gfc_set_sym_referenced (dealloc
);
2561 /* Set up formal argument. */
2562 gfc_get_symbol ("arg", sub_ns
, &arg
);
2563 arg
->ts
.type
= BT_DERIVED
;
2564 arg
->ts
.u
.derived
= derived
;
2565 arg
->attr
.flavor
= FL_VARIABLE
;
2566 arg
->attr
.dummy
= 1;
2567 arg
->attr
.artificial
= 1;
2568 arg
->attr
.intent
= INTENT_INOUT
;
2569 arg
->attr
.dimension
= 1;
2570 arg
->attr
.allocatable
= 1;
2571 arg
->as
= gfc_get_array_spec();
2572 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2574 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2576 gfc_set_sym_referenced (arg
);
2577 dealloc
->formal
= gfc_get_formal_arglist ();
2578 dealloc
->formal
->sym
= arg
;
2580 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2581 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2582 sub_ns
->code
->ext
.alloc
.list
->expr
2583 = gfc_lval_expr_from_sym (arg
);
2584 /* Set initializer. */
2585 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2586 c
->ts
.interface
= dealloc
;
2589 /* Add procedure pointers for type-bound procedures. */
2590 if (!derived
->attr
.unlimited_polymorphic
)
2591 add_procs_to_declared_vtab (derived
, vtype
);
2595 vtab
->ts
.u
.derived
= vtype
;
2596 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2604 /* It is unexpected to have some symbols added at resolution or code
2605 generation time. We commit the changes in order to keep a clean state. */
2608 gfc_commit_symbol (vtab
);
2610 gfc_commit_symbol (vtype
);
2612 gfc_commit_symbol (def_init
);
2614 gfc_commit_symbol (copy
);
2616 gfc_commit_symbol (src
);
2618 gfc_commit_symbol (dst
);
2620 gfc_commit_symbol (dealloc
);
2622 gfc_commit_symbol (arg
);
2625 gfc_undo_symbols ();
2631 /* Check if a derived type is finalizable. That is the case if it
2632 (1) has a FINAL subroutine or
2633 (2) has a nonpointer nonallocatable component of finalizable type.
2634 If it is finalizable, return an expression containing the
2635 finalization wrapper. */
2638 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2643 /* (1) Check for FINAL subroutines. */
2644 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2647 /* (2) Check for components of finalizable type. */
2648 for (c
= derived
->components
; c
; c
= c
->next
)
2649 if (c
->ts
.type
== BT_DERIVED
2650 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2651 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2657 /* Make sure vtab is generated. */
2658 vtab
= gfc_find_derived_vtab (derived
);
2661 /* Return finalizer expression. */
2662 gfc_component
*final
;
2663 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2664 gcc_assert (strcmp (final
->name
, "_final") == 0);
2665 gcc_assert (final
->initializer
2666 && final
->initializer
->expr_type
!= EXPR_NULL
);
2667 *final_expr
= final
->initializer
;
2673 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2674 needed to support unlimited polymorphism. */
2677 find_intrinsic_vtab (gfc_typespec
*ts
)
2680 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2681 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2683 /* Find the top-level namespace. */
2684 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2690 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2693 /* Encode all types as TYPENAME_KIND_ including especially character
2694 arrays, whose length is now consistently stored in the _len component
2695 of the class-variable. */
2696 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2697 name
= xasprintf ("__vtab_%s", tname
);
2699 /* Look for the vtab symbol in the top-level namespace only. */
2700 gfc_find_symbol (name
, ns
, 0, &vtab
);
2704 gfc_get_symbol (name
, ns
, &vtab
);
2705 vtab
->ts
.type
= BT_DERIVED
;
2706 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2707 &gfc_current_locus
))
2709 vtab
->attr
.target
= 1;
2710 vtab
->attr
.save
= SAVE_IMPLICIT
;
2711 vtab
->attr
.vtab
= 1;
2712 vtab
->attr
.access
= ACCESS_PUBLIC
;
2713 gfc_set_sym_referenced (vtab
);
2714 name
= xasprintf ("__vtype_%s", tname
);
2716 gfc_find_symbol (name
, ns
, 0, &vtype
);
2721 gfc_namespace
*sub_ns
;
2722 gfc_namespace
*contained
;
2726 gfc_get_symbol (name
, ns
, &vtype
);
2727 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2728 &gfc_current_locus
))
2730 vtype
->attr
.access
= ACCESS_PUBLIC
;
2731 vtype
->attr
.vtype
= 1;
2732 gfc_set_sym_referenced (vtype
);
2734 /* Add component '_hash'. */
2735 if (!gfc_add_component (vtype
, "_hash", &c
))
2737 c
->ts
.type
= BT_INTEGER
;
2739 c
->attr
.access
= ACCESS_PRIVATE
;
2740 hash
= gfc_intrinsic_hash_value (ts
);
2741 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2744 /* Add component '_size'. */
2745 if (!gfc_add_component (vtype
, "_size", &c
))
2747 c
->ts
.type
= BT_INTEGER
;
2748 c
->ts
.kind
= gfc_size_kind
;
2749 c
->attr
.access
= ACCESS_PRIVATE
;
2751 /* Build a minimal expression to make use of
2752 target-memory.c/gfc_element_size for 'size'. Special handling
2753 for character arrays, that are not constant sized: to support
2754 len (str) * kind, only the kind information is stored in the
2756 e
= gfc_get_expr ();
2758 e
->expr_type
= EXPR_VARIABLE
;
2759 if (ts
->type
== BT_CHARACTER
)
2762 gfc_element_size (e
, &e_size
);
2763 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2768 /* Add component _extends. */
2769 if (!gfc_add_component (vtype
, "_extends", &c
))
2771 c
->attr
.pointer
= 1;
2772 c
->attr
.access
= ACCESS_PRIVATE
;
2773 c
->ts
.type
= BT_VOID
;
2774 c
->initializer
= gfc_get_null_expr (NULL
);
2776 /* Add component _def_init. */
2777 if (!gfc_add_component (vtype
, "_def_init", &c
))
2779 c
->attr
.pointer
= 1;
2780 c
->attr
.access
= ACCESS_PRIVATE
;
2781 c
->ts
.type
= BT_VOID
;
2782 c
->initializer
= gfc_get_null_expr (NULL
);
2784 /* Add component _copy. */
2785 if (!gfc_add_component (vtype
, "_copy", &c
))
2787 c
->attr
.proc_pointer
= 1;
2788 c
->attr
.access
= ACCESS_PRIVATE
;
2789 c
->tb
= XCNEW (gfc_typebound_proc
);
2792 if (ts
->type
!= BT_CHARACTER
)
2793 name
= xasprintf ("__copy_%s", tname
);
2796 /* __copy is always the same for characters.
2797 Check to see if copy function already exists. */
2798 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2799 contained
= ns
->contained
;
2800 for (; contained
; contained
= contained
->sibling
)
2801 if (contained
->proc_name
2802 && strcmp (name
, contained
->proc_name
->name
) == 0)
2804 copy
= contained
->proc_name
;
2809 /* Set up namespace. */
2810 sub_ns
= gfc_get_namespace (ns
, 0);
2811 sub_ns
->sibling
= ns
->contained
;
2812 ns
->contained
= sub_ns
;
2813 sub_ns
->resolved
= 1;
2814 /* Set up procedure symbol. */
2815 gfc_get_symbol (name
, sub_ns
, ©
);
2816 sub_ns
->proc_name
= copy
;
2817 copy
->attr
.flavor
= FL_PROCEDURE
;
2818 copy
->attr
.subroutine
= 1;
2819 copy
->attr
.pure
= 1;
2820 copy
->attr
.if_source
= IFSRC_DECL
;
2821 /* This is elemental so that arrays are automatically
2822 treated correctly by the scalarizer. */
2823 copy
->attr
.elemental
= 1;
2824 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2825 copy
->module
= ns
->proc_name
->name
;
2826 gfc_set_sym_referenced (copy
);
2827 /* Set up formal arguments. */
2828 gfc_get_symbol ("src", sub_ns
, &src
);
2829 src
->ts
.type
= ts
->type
;
2830 src
->ts
.kind
= ts
->kind
;
2831 src
->attr
.flavor
= FL_VARIABLE
;
2832 src
->attr
.dummy
= 1;
2833 src
->attr
.intent
= INTENT_IN
;
2834 gfc_set_sym_referenced (src
);
2835 copy
->formal
= gfc_get_formal_arglist ();
2836 copy
->formal
->sym
= src
;
2837 gfc_get_symbol ("dst", sub_ns
, &dst
);
2838 dst
->ts
.type
= ts
->type
;
2839 dst
->ts
.kind
= ts
->kind
;
2840 dst
->attr
.flavor
= FL_VARIABLE
;
2841 dst
->attr
.dummy
= 1;
2842 dst
->attr
.intent
= INTENT_INOUT
;
2843 gfc_set_sym_referenced (dst
);
2844 copy
->formal
->next
= gfc_get_formal_arglist ();
2845 copy
->formal
->next
->sym
= dst
;
2847 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2848 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2849 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2851 /* Set initializer. */
2852 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2853 c
->ts
.interface
= copy
;
2855 /* Add component _final. */
2856 if (!gfc_add_component (vtype
, "_final", &c
))
2858 c
->attr
.proc_pointer
= 1;
2859 c
->attr
.access
= ACCESS_PRIVATE
;
2860 c
->attr
.artificial
= 1;
2861 c
->tb
= XCNEW (gfc_typebound_proc
);
2863 c
->initializer
= gfc_get_null_expr (NULL
);
2865 vtab
->ts
.u
.derived
= vtype
;
2866 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2874 /* It is unexpected to have some symbols added at resolution or code
2875 generation time. We commit the changes in order to keep a clean state. */
2878 gfc_commit_symbol (vtab
);
2880 gfc_commit_symbol (vtype
);
2882 gfc_commit_symbol (copy
);
2884 gfc_commit_symbol (src
);
2886 gfc_commit_symbol (dst
);
2889 gfc_undo_symbols ();
2895 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2898 gfc_find_vtab (gfc_typespec
*ts
)
2905 return gfc_find_derived_vtab (ts
->u
.derived
);
2907 if (ts
->u
.derived
->components
&& ts
->u
.derived
->components
->ts
.u
.derived
)
2908 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2912 return find_intrinsic_vtab (ts
);
2917 /* General worker function to find either a type-bound procedure or a
2918 type-bound user operator. */
2921 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2922 const char* name
, bool noaccess
, bool uop
,
2928 /* Set default to failure. */
2932 if (derived
->f2k_derived
)
2933 /* Set correct symbol-root. */
2934 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2935 : derived
->f2k_derived
->tb_sym_root
);
2939 /* Try to find it in the current type's namespace. */
2940 res
= gfc_find_symtree (root
, name
);
2941 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2947 if (!noaccess
&& derived
->attr
.use_assoc
2948 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2951 gfc_error ("%qs of %qs is PRIVATE at %L",
2952 name
, derived
->name
, where
);
2960 /* Otherwise, recurse on parent type if derived is an extension. */
2961 if (derived
->attr
.extension
)
2963 gfc_symbol
* super_type
;
2964 super_type
= gfc_get_derived_super_type (derived
);
2965 gcc_assert (super_type
);
2967 return find_typebound_proc_uop (super_type
, t
, name
,
2968 noaccess
, uop
, where
);
2971 /* Nothing found. */
2976 /* Find a type-bound procedure or user operator by name for a derived-type
2977 (looking recursively through the super-types). */
2980 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2981 const char* name
, bool noaccess
, locus
* where
)
2983 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2987 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2988 const char* name
, bool noaccess
, locus
* where
)
2990 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2994 /* Find a type-bound intrinsic operator looking recursively through the
2995 super-type hierarchy. */
2998 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2999 gfc_intrinsic_op op
, bool noaccess
,
3002 gfc_typebound_proc
* res
;
3004 /* Set default to failure. */
3008 /* Try to find it in the current type's namespace. */
3009 if (derived
->f2k_derived
)
3010 res
= derived
->f2k_derived
->tb_op
[op
];
3015 if (res
&& !res
->error
)
3021 if (!noaccess
&& derived
->attr
.use_assoc
3022 && res
->access
== ACCESS_PRIVATE
)
3025 gfc_error ("%qs of %qs is PRIVATE at %L",
3026 gfc_op2string (op
), derived
->name
, where
);
3034 /* Otherwise, recurse on parent type if derived is an extension. */
3035 if (derived
->attr
.extension
)
3037 gfc_symbol
* super_type
;
3038 super_type
= gfc_get_derived_super_type (derived
);
3039 gcc_assert (super_type
);
3041 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3045 /* Nothing found. */
3050 /* Get a typebound-procedure symtree or create and insert it if not yet
3051 present. This is like a very simplified version of gfc_get_sym_tree for
3052 tbp-symtrees rather than regular ones. */
3055 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3057 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3058 return result
? result
: gfc_new_symtree (root
, name
);