1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2015 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(4) 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
);
79 type_sym
= ts
->u
.derived
;
81 new_ref
= gfc_get_ref ();
82 new_ref
->type
= REF_COMPONENT
;
84 new_ref
->u
.c
.sym
= type_sym
;
85 new_ref
->u
.c
.component
= gfc_find_component (type_sym
, name
, true, true);
86 gcc_assert (new_ref
->u
.c
.component
);
92 /* We need to update the base type in the trailing reference chain to
93 that of the new component. */
95 gcc_assert (strcmp (name
, "_data") == 0);
97 if (new_ref
->next
->type
== REF_COMPONENT
)
99 else if (new_ref
->next
->type
== REF_ARRAY
100 && new_ref
->next
->next
101 && new_ref
->next
->next
->type
== REF_COMPONENT
)
102 next
= new_ref
->next
->next
;
106 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
107 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
108 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
116 /* Tells whether we need to add a "_data" reference to access REF subobject
117 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
118 object accessed by REF is a variable; in other words it is a full object,
122 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
124 /* Only class containers may need the "_data" reference. */
125 if (ts
->type
!= BT_CLASS
)
128 /* Accessing a class container with an array reference is certainly wrong. */
129 if (ref
->type
!= REF_COMPONENT
)
132 /* Accessing the class container's fields is fine. */
133 if (ref
->u
.c
.component
->name
[0] == '_')
136 /* At this point we have a class container with a non class container's field
137 component reference. We don't want to add the "_data" component if we are
138 at the first reference and the symbol's type is an extended derived type.
139 In that case, conv_parent_component_references will do the right thing so
140 it is not absolutely necessary. Omitting it prevents a regression (see
141 class_41.f03) in the interface mapping mechanism. When evaluating string
142 lengths depending on dummy arguments, we create a fake symbol with a type
143 equal to that of the dummy type. However, because of type extension,
144 the backend type (corresponding to the actual argument) can have a
145 different (extended) type. Adding the "_data" component explicitly, using
146 the base type, confuses the gfc_conv_component_ref code which deals with
147 the extended type. */
148 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
151 /* We have a class container with a non class container's field component
152 reference that doesn't fall into the above. */
157 /* Browse through a data reference chain and add the missing "_data" references
158 when a subobject of a class object is accessed without it.
159 Note that it doesn't add the "_data" reference when the class container
160 is the last element in the reference chain. */
163 gfc_fix_class_refs (gfc_expr
*e
)
168 if ((e
->expr_type
!= EXPR_VARIABLE
169 && e
->expr_type
!= EXPR_FUNCTION
)
170 || (e
->expr_type
== EXPR_FUNCTION
171 && e
->value
.function
.isym
!= NULL
))
174 if (e
->expr_type
== EXPR_VARIABLE
)
175 ts
= &e
->symtree
->n
.sym
->ts
;
180 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
181 if (e
->value
.function
.esym
!= NULL
)
182 func
= e
->value
.function
.esym
;
184 func
= e
->symtree
->n
.sym
;
186 if (func
->result
!= NULL
)
187 ts
= &func
->result
->ts
;
192 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
194 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
195 insert_component_ref (ts
, ref
, "_data");
197 if ((*ref
)->type
== REF_COMPONENT
)
198 ts
= &(*ref
)->u
.c
.component
->ts
;
203 /* Insert a reference to the component of the given name.
204 Only to be used with CLASS containers and vtables. */
207 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
209 gfc_ref
**tail
= &(e
->ref
);
210 gfc_ref
*next
= NULL
;
211 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
212 while (*tail
!= NULL
)
214 if ((*tail
)->type
== REF_COMPONENT
)
216 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
218 && (*tail
)->next
->type
== REF_ARRAY
219 && (*tail
)->next
->next
== NULL
)
221 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
223 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
225 tail
= &((*tail
)->next
);
227 if (derived
->components
->next
->ts
.type
== BT_DERIVED
&&
228 derived
->components
->next
->ts
.u
.derived
== NULL
)
230 /* Fix up missing vtype. */
231 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
233 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
235 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
237 (*tail
) = gfc_get_ref();
238 (*tail
)->next
= next
;
239 (*tail
)->type
= REF_COMPONENT
;
240 (*tail
)->u
.c
.sym
= derived
;
241 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
242 gcc_assert((*tail
)->u
.c
.component
);
244 e
->ts
= (*tail
)->u
.c
.component
->ts
;
248 /* This is used to add both the _data component reference and an array
249 reference to class expressions. Used in translation of intrinsic
250 array inquiry functions. */
253 gfc_add_class_array_ref (gfc_expr
*e
)
255 int rank
= CLASS_DATA (e
)->as
->rank
;
256 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
258 gfc_add_component_ref (e
, "_data");
260 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
263 if (ref
->type
!= REF_ARRAY
)
265 ref
->next
= gfc_get_ref ();
267 ref
->type
= REF_ARRAY
;
268 ref
->u
.ar
.type
= AR_FULL
;
274 /* Unfortunately, class array expressions can appear in various conditions;
275 with and without both _data component and an arrayspec. This function
276 deals with that variability. The previous reference to 'ref' is to a
280 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
282 bool no_data
= false;
283 bool with_data
= false;
285 /* An array reference with no _data component. */
286 if (ref
&& ref
->type
== REF_ARRAY
288 && ref
->u
.ar
.type
!= AR_ELEMENT
)
291 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
295 /* Cover cases where _data appears, with or without an array ref. */
296 if (ref
&& ref
->type
== REF_COMPONENT
297 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
305 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
307 && ref
->type
== REF_COMPONENT
308 && ref
->next
->type
== REF_ARRAY
309 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
313 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
317 return no_data
|| with_data
;
321 /* Returns true if the expression contains a reference to a class
322 array. Notice that class array elements return false. */
325 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
335 /* Is this a class array object? ie. Is the symbol of type class? */
337 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
338 && CLASS_DATA (e
->symtree
->n
.sym
)
339 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
340 && class_array_ref_detected (e
->ref
, full_array
))
343 /* Or is this a class array component reference? */
344 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
346 if (ref
->type
== REF_COMPONENT
347 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
348 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
349 && class_array_ref_detected (ref
->next
, full_array
))
357 /* Returns true if the expression is a reference to a class
358 scalar. This function is necessary because such expressions
359 can be dressed with a reference to the _data component and so
360 have a type other than BT_CLASS. */
363 gfc_is_class_scalar_expr (gfc_expr
*e
)
370 /* Is this a class object? */
372 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
373 && CLASS_DATA (e
->symtree
->n
.sym
)
374 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
376 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
377 && e
->ref
->next
== NULL
)))
380 /* Or is the final reference BT_CLASS or _data? */
381 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
383 if (ref
->type
== REF_COMPONENT
384 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
385 && CLASS_DATA (ref
->u
.c
.component
)
386 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
387 && (ref
->next
== NULL
388 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
389 && ref
->next
->next
== NULL
)))
397 /* Tells whether the expression E is a reference to a (scalar) class container.
398 Scalar because array class containers usually have an array reference after
399 them, and gfc_fix_class_refs will add the missing "_data" component reference
403 gfc_is_class_container_ref (gfc_expr
*e
)
408 if (e
->expr_type
!= EXPR_VARIABLE
)
409 return e
->ts
.type
== BT_CLASS
;
411 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
416 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
418 if (ref
->type
!= REF_COMPONENT
)
420 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
430 /* Build an initializer for CLASS pointers,
431 initializing the _data component to the init_expr (or NULL) and the _vptr
432 component to the corresponding type (or the declared type, given by ts). */
435 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
439 gfc_symbol
*vtab
= NULL
;
441 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
442 vtab
= gfc_find_vtab (&init_expr
->ts
);
444 vtab
= gfc_find_vtab (ts
);
446 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
447 &ts
->u
.derived
->declared_at
);
450 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
452 gfc_constructor
*ctor
= gfc_constructor_get();
453 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
454 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
455 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
456 ctor
->expr
= gfc_copy_expr (init_expr
);
458 ctor
->expr
= gfc_get_null_expr (NULL
);
459 gfc_constructor_append (&init
->value
.constructor
, ctor
);
466 /* Create a unique string identifier for a derived type, composed of its name
467 and module name. This is used to construct unique names for the class
468 containers and vtab symbols. */
471 get_unique_type_string (char *string
, gfc_symbol
*derived
)
473 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
474 if (derived
->attr
.unlimited_polymorphic
)
475 strcpy (dt_name
, "STAR");
477 strcpy (dt_name
, derived
->name
);
478 dt_name
[0] = TOUPPER (dt_name
[0]);
479 if (derived
->attr
.unlimited_polymorphic
)
480 sprintf (string
, "_%s", dt_name
);
481 else if (derived
->module
)
482 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
483 else if (derived
->ns
->proc_name
)
484 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
486 sprintf (string
, "_%s", dt_name
);
490 /* A relative of 'get_unique_type_string' which makes sure the generated
491 string will not be too long (replacing it by a hash string if needed). */
494 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
496 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
497 get_unique_type_string (&tmp
[0], derived
);
498 /* If string is too long, use hash value in hex representation (allow for
499 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
500 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
501 where %d is the (co)rank which can be up to n = 15. */
502 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
504 int h
= gfc_hash_value (derived
);
505 sprintf (string
, "%X", h
);
508 strcpy (string
, tmp
);
512 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
515 gfc_hash_value (gfc_symbol
*sym
)
517 unsigned int hash
= 0;
518 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
521 get_unique_type_string (&c
[0], sym
);
524 for (i
= 0; i
< len
; i
++)
525 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
527 /* Return the hash but take the modulus for the sake of module read,
528 even though this slightly increases the chance of collision. */
529 return (hash
% 100000000);
533 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
536 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
538 unsigned int hash
= 0;
539 const char *c
= gfc_typename (ts
);
544 for (i
= 0; i
< len
; i
++)
545 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
547 /* Return the hash but take the modulus for the sake of module read,
548 even though this slightly increases the chance of collision. */
549 return (hash
% 100000000);
553 /* Get the _len component from a class/derived object storing a string.
554 For unlimited polymorphic entities a ref to the _data component is available
555 while a ref to the _len component is needed. This routine traverese the
556 ref-chain and strips the last ref to a _data from it replacing it with a
557 ref to the _len component. */
560 gfc_get_len_component (gfc_expr
*e
)
563 gfc_ref
*ref
, **last
;
565 ptr
= gfc_copy_expr (e
);
567 /* We need to remove the last _data component ref from ptr. */
573 && ref
->type
== REF_COMPONENT
574 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
576 gfc_free_ref_list (ref
);
583 /* And replace if with a ref to the _len component. */
584 gfc_add_component_ref (ptr
, "_len");
589 /* Build a polymorphic CLASS entity, using the symbol that comes from
590 build_sym. A CLASS entity is represented by an encapsulating type,
591 which contains the declared type as '_data' component, plus a pointer
592 component '_vptr' which determines the dynamic type. When this CLASS
593 entity is unlimited polymorphic, then also add a component '_len' to
594 store the length of string when that is stored in it. */
597 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
600 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
609 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
611 gfc_error ("Assumed size polymorphic objects or components, such "
612 "as that at %C, have not yet been implemented");
617 /* Class container has already been built. */
620 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
621 || attr
->select_type_temporary
|| attr
->associate_var
;
624 /* We can not build the class container yet. */
627 /* Determine the name of the encapsulating type. */
628 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
629 get_unique_hashed_string (tname
, ts
->u
.derived
);
630 if ((*as
) && attr
->allocatable
)
631 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
632 else if ((*as
) && attr
->pointer
)
633 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
635 sprintf (name
, "__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
636 else if (attr
->pointer
)
637 sprintf (name
, "__class_%s_p", tname
);
638 else if (attr
->allocatable
)
639 sprintf (name
, "__class_%s_a", tname
);
641 sprintf (name
, "__class_%s_t", tname
);
643 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
645 /* Find the top-level namespace. */
646 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
651 ns
= ts
->u
.derived
->ns
;
653 gfc_find_symbol (name
, ns
, 0, &fclass
);
657 /* If not there, create a new symbol. */
658 fclass
= gfc_new_symbol (name
, ns
);
659 st
= gfc_new_symtree (&ns
->sym_root
, name
);
661 gfc_set_sym_referenced (fclass
);
663 fclass
->ts
.type
= BT_UNKNOWN
;
664 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
665 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
666 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
667 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
671 /* Add component '_data'. */
672 if (!gfc_add_component (fclass
, "_data", &c
))
675 c
->ts
.type
= BT_DERIVED
;
676 c
->attr
.access
= ACCESS_PRIVATE
;
677 c
->ts
.u
.derived
= ts
->u
.derived
;
678 c
->attr
.class_pointer
= attr
->pointer
;
679 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
680 || attr
->select_type_temporary
;
681 c
->attr
.allocatable
= attr
->allocatable
;
682 c
->attr
.dimension
= attr
->dimension
;
683 c
->attr
.codimension
= attr
->codimension
;
684 c
->attr
.abstract
= fclass
->attr
.abstract
;
686 c
->initializer
= NULL
;
688 /* Add component '_vptr'. */
689 if (!gfc_add_component (fclass
, "_vptr", &c
))
691 c
->ts
.type
= BT_DERIVED
;
692 c
->attr
.access
= ACCESS_PRIVATE
;
695 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
697 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
699 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
701 /* Add component '_len'. Only unlimited polymorphic pointers may
702 have a string assigned to them, i.e., only those need the _len
704 if (!gfc_add_component (fclass
, "_len", &c
))
706 c
->ts
.type
= BT_INTEGER
;
708 c
->attr
.access
= ACCESS_PRIVATE
;
709 c
->attr
.artificial
= 1;
712 /* Build vtab later. */
713 c
->ts
.u
.derived
= NULL
;
716 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
718 /* Since the extension field is 8 bit wide, we can only have
719 up to 255 extension levels. */
720 if (ts
->u
.derived
->attr
.extension
== 255)
722 gfc_error ("Maximum extension level reached with type %qs at %L",
723 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
727 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
728 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
729 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
732 fclass
->attr
.is_class
= 1;
733 ts
->u
.derived
= fclass
;
734 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
740 /* Add a procedure pointer component to the vtype
741 to represent a specific type-bound procedure. */
744 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
748 if (tb
->non_overridable
)
751 c
= gfc_find_component (vtype
, name
, true, true);
755 /* Add procedure component. */
756 if (!gfc_add_component (vtype
, name
, &c
))
760 c
->tb
= XCNEW (gfc_typebound_proc
);
763 c
->attr
.procedure
= 1;
764 c
->attr
.proc_pointer
= 1;
765 c
->attr
.flavor
= FL_PROCEDURE
;
766 c
->attr
.access
= ACCESS_PRIVATE
;
767 c
->attr
.external
= 1;
769 c
->attr
.if_source
= IFSRC_IFBODY
;
771 else if (c
->attr
.proc_pointer
&& c
->tb
)
779 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
780 c
->ts
.interface
= ifc
;
782 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
783 c
->attr
.pure
= ifc
->attr
.pure
;
788 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
791 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
797 add_procs_to_declared_vtab1 (st
->left
, vtype
);
800 add_procs_to_declared_vtab1 (st
->right
, vtype
);
802 if (st
->n
.tb
&& !st
->n
.tb
->error
803 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
804 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
808 /* Copy procedure pointers components from the parent type. */
811 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
816 vtab
= gfc_find_derived_vtab (declared
);
818 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
820 if (gfc_find_component (vtype
, cmp
->name
, true, true))
823 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
828 /* Returns true if any of its nonpointer nonallocatable components or
829 their nonpointer nonallocatable subcomponents has a finalization
833 has_finalizer_component (gfc_symbol
*derived
)
837 for (c
= derived
->components
; c
; c
= c
->next
)
839 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
840 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
843 if (c
->ts
.type
== BT_DERIVED
844 && !c
->attr
.pointer
&& !c
->attr
.allocatable
845 && has_finalizer_component (c
->ts
.u
.derived
))
853 comp_is_finalizable (gfc_component
*comp
)
855 if (comp
->attr
.proc_pointer
)
857 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
859 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
860 && (comp
->ts
.u
.derived
->attr
.alloc_comp
861 || has_finalizer_component (comp
->ts
.u
.derived
)
862 || (comp
->ts
.u
.derived
->f2k_derived
863 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
865 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
866 && CLASS_DATA (comp
)->attr
.allocatable
)
873 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
874 neither allocatable nor a pointer but has a finalizer, call it. If it
875 is a nonpointer component with allocatable components or has finalizers, walk
876 them. Either of them is required; other nonallocatables and pointers aren't
878 Note: If the component is allocatable, the DEALLOCATE handling takes care
879 of calling the appropriate finalizers, coarray deregistering, and
880 deallocation of allocatable subcomponents. */
883 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
884 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
885 gfc_namespace
*sub_ns
)
890 if (!comp_is_finalizable (comp
))
893 e
= gfc_copy_expr (expr
);
895 e
->ref
= ref
= gfc_get_ref ();
898 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
900 ref
->next
= gfc_get_ref ();
903 ref
->type
= REF_COMPONENT
;
904 ref
->u
.c
.sym
= derived
;
905 ref
->u
.c
.component
= comp
;
908 if (comp
->attr
.dimension
|| comp
->attr
.codimension
909 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
910 && (CLASS_DATA (comp
)->attr
.dimension
911 || CLASS_DATA (comp
)->attr
.codimension
)))
913 ref
->next
= gfc_get_ref ();
914 ref
->next
->type
= REF_ARRAY
;
915 ref
->next
->u
.ar
.dimen
= 0;
916 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
918 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
919 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
922 /* Call DEALLOCATE (comp, stat=ignore). */
923 if (comp
->attr
.allocatable
924 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
925 && CLASS_DATA (comp
)->attr
.allocatable
))
927 gfc_code
*dealloc
, *block
= NULL
;
929 /* Add IF (fini_coarray). */
930 if (comp
->attr
.codimension
931 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
932 && CLASS_DATA (comp
)->attr
.codimension
))
934 block
= gfc_get_code (EXEC_IF
);
937 (*code
)->next
= block
;
938 (*code
) = (*code
)->next
;
943 block
->block
= gfc_get_code (EXEC_IF
);
944 block
= block
->block
;
945 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
948 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
950 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
951 dealloc
->ext
.alloc
.list
->expr
= e
;
952 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
954 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
955 cond
->block
= gfc_get_code (EXEC_IF
);
956 cond
->block
->expr1
= gfc_get_expr ();
957 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
958 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
959 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
960 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
961 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
962 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
963 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
964 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
965 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
966 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
967 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
968 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
969 cond
->block
->next
= dealloc
;
975 (*code
)->next
= cond
;
976 (*code
) = (*code
)->next
;
981 else if (comp
->ts
.type
== BT_DERIVED
982 && comp
->ts
.u
.derived
->f2k_derived
983 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
985 /* Call FINAL_WRAPPER (comp); */
986 gfc_code
*final_wrap
;
990 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
991 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
992 if (strcmp (c
->name
, "_final") == 0)
996 final_wrap
= gfc_get_code (EXEC_CALL
);
997 final_wrap
->symtree
= c
->initializer
->symtree
;
998 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
999 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1000 final_wrap
->ext
.actual
->expr
= e
;
1004 (*code
)->next
= final_wrap
;
1005 (*code
) = (*code
)->next
;
1008 (*code
) = final_wrap
;
1014 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1015 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1022 /* Generate code equivalent to
1023 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1024 + offset, c_ptr), ptr). */
1027 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1028 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1031 gfc_expr
*expr
, *expr2
;
1033 /* C_F_POINTER(). */
1034 block
= gfc_get_code (EXEC_CALL
);
1035 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1036 block
->resolved_sym
= block
->symtree
->n
.sym
;
1037 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1038 block
->resolved_sym
->attr
.intrinsic
= 1;
1039 block
->resolved_sym
->attr
.subroutine
= 1;
1040 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1041 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1042 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1043 gfc_commit_symbol (block
->resolved_sym
);
1045 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1046 block
->ext
.actual
= gfc_get_actual_arglist ();
1047 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1048 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1050 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1052 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1054 /* TRANSFER's first argument: C_LOC (array). */
1055 expr
= gfc_get_expr ();
1056 expr
->expr_type
= EXPR_FUNCTION
;
1057 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1058 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1059 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1060 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1061 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1062 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1063 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1064 expr
->value
.function
.actual
->expr
1065 = gfc_lval_expr_from_sym (array
);
1066 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1067 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1068 expr
->ts
.type
= BT_INTEGER
;
1069 expr
->ts
.kind
= gfc_index_integer_kind
;
1072 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1073 gfc_current_locus
, 3, expr
,
1074 gfc_get_int_expr (gfc_index_integer_kind
,
1076 expr2
->ts
.type
= BT_INTEGER
;
1077 expr2
->ts
.kind
= gfc_index_integer_kind
;
1079 /* <array addr> + <offset>. */
1080 block
->ext
.actual
->expr
= gfc_get_expr ();
1081 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1082 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1083 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1084 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1085 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1087 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1088 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1089 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1090 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1096 /* Calculates the offset to the (idx+1)th element of an array, taking the
1097 stride into account. It generates the code:
1100 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1102 offset = offset * byte_stride. */
1105 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1106 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1107 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1108 gfc_code
*block
, gfc_namespace
*sub_ns
)
1111 gfc_expr
*expr
, *expr2
;
1114 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1115 block
= block
->next
;
1116 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1117 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1120 iter
= gfc_get_iterator ();
1121 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1122 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1123 iter
->end
= gfc_copy_expr (rank
);
1124 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1125 block
->next
= gfc_get_code (EXEC_DO
);
1126 block
= block
->next
;
1127 block
->ext
.iterator
= iter
;
1128 block
->block
= gfc_get_code (EXEC_DO
);
1130 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1133 /* mod (idx, sizes(idx2)). */
1134 expr
= gfc_lval_expr_from_sym (sizes
);
1135 expr
->ref
= gfc_get_ref ();
1136 expr
->ref
->type
= REF_ARRAY
;
1137 expr
->ref
->u
.ar
.as
= sizes
->as
;
1138 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1139 expr
->ref
->u
.ar
.dimen
= 1;
1140 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1141 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1143 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1144 gfc_current_locus
, 2,
1145 gfc_lval_expr_from_sym (idx
), expr
);
1148 /* (...) / sizes(idx2-1). */
1149 expr2
= gfc_get_expr ();
1150 expr2
->expr_type
= EXPR_OP
;
1151 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1152 expr2
->value
.op
.op1
= expr
;
1153 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1154 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1155 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1156 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1157 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1158 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1159 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1160 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1161 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1162 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1163 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1164 = gfc_lval_expr_from_sym (idx2
);
1165 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1166 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1167 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1168 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1169 expr2
->ts
= idx
->ts
;
1171 /* ... * strides(idx2). */
1172 expr
= gfc_get_expr ();
1173 expr
->expr_type
= EXPR_OP
;
1174 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1175 expr
->value
.op
.op1
= expr2
;
1176 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1177 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1178 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1179 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1180 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1181 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1182 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1183 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1186 /* offset = offset + ... */
1187 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1188 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1189 block
->block
->next
->expr2
= gfc_get_expr ();
1190 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1191 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1192 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1193 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1194 block
->block
->next
->expr2
->ts
= idx
->ts
;
1196 /* After the loop: offset = offset * byte_stride. */
1197 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1198 block
= block
->next
;
1199 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1200 block
->expr2
= gfc_get_expr ();
1201 block
->expr2
->expr_type
= EXPR_OP
;
1202 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1203 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1204 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1205 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1210 /* Insert code of the following form:
1213 integer(c_intptr_t) :: i
1215 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1216 && (is_contiguous || !final_rank3->attr.contiguous
1217 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1218 || 0 == STORAGE_SIZE (array)) then
1219 call final_rank3 (array)
1222 integer(c_intptr_t) :: offset, j
1223 type(t) :: tmp(shape (array))
1225 do i = 0, size (array)-1
1226 offset = obtain_offset(i, strides, sizes, byte_stride)
1227 addr = transfer (c_loc (array), addr) + offset
1228 call c_f_pointer (transfer (addr, cptr), ptr)
1230 addr = transfer (c_loc (tmp), addr)
1231 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1232 call c_f_pointer (transfer (addr, cptr), ptr2)
1235 call final_rank3 (tmp)
1241 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1242 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1243 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1245 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1246 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1247 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1248 gfc_namespace
*sub_ns
)
1250 gfc_symbol
*tmp_array
, *ptr2
;
1251 gfc_expr
*size_expr
, *offset2
, *expr
;
1257 block
->next
= gfc_get_code (EXEC_IF
);
1258 block
= block
->next
;
1260 block
->block
= gfc_get_code (EXEC_IF
);
1261 block
= block
->block
;
1263 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1264 size_expr
= gfc_get_expr ();
1265 size_expr
->where
= gfc_current_locus
;
1266 size_expr
->expr_type
= EXPR_OP
;
1267 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1269 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1270 size_expr
->value
.op
.op1
1271 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1272 "storage_size", gfc_current_locus
, 2,
1273 gfc_lval_expr_from_sym (array
),
1274 gfc_get_int_expr (gfc_index_integer_kind
,
1277 /* NUMERIC_STORAGE_SIZE. */
1278 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1279 gfc_character_storage_size
);
1280 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1281 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1283 /* IF condition: (stride == size_expr
1284 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1286 || 0 == size_expr. */
1287 block
->expr1
= gfc_get_expr ();
1288 block
->expr1
->ts
.type
= BT_LOGICAL
;
1289 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1290 block
->expr1
->expr_type
= EXPR_OP
;
1291 block
->expr1
->where
= gfc_current_locus
;
1293 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1295 /* byte_stride == size_expr */
1296 expr
= gfc_get_expr ();
1297 expr
->ts
.type
= BT_LOGICAL
;
1298 expr
->ts
.kind
= gfc_default_logical_kind
;
1299 expr
->expr_type
= EXPR_OP
;
1300 expr
->where
= gfc_current_locus
;
1301 expr
->value
.op
.op
= INTRINSIC_EQ
;
1303 = gfc_lval_expr_from_sym (byte_stride
);
1304 expr
->value
.op
.op2
= size_expr
;
1306 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1307 add is_contiguous check. */
1309 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1310 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1313 expr2
= gfc_get_expr ();
1314 expr2
->ts
.type
= BT_LOGICAL
;
1315 expr2
->ts
.kind
= gfc_default_logical_kind
;
1316 expr2
->expr_type
= EXPR_OP
;
1317 expr2
->where
= gfc_current_locus
;
1318 expr2
->value
.op
.op
= INTRINSIC_AND
;
1319 expr2
->value
.op
.op1
= expr
;
1320 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1324 block
->expr1
->value
.op
.op1
= expr
;
1326 /* 0 == size_expr */
1327 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1328 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1329 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1330 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1331 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1332 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1333 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1334 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1335 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1337 /* IF body: call final subroutine. */
1338 block
->next
= gfc_get_code (EXEC_CALL
);
1339 block
->next
->symtree
= fini
->proc_tree
;
1340 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1341 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1342 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1346 block
->block
= gfc_get_code (EXEC_IF
);
1347 block
= block
->block
;
1349 /* BLOCK ... END BLOCK. */
1350 block
->next
= gfc_get_code (EXEC_BLOCK
);
1351 block
= block
->next
;
1353 ns
= gfc_build_block_ns (sub_ns
);
1354 block
->ext
.block
.ns
= ns
;
1355 block
->ext
.block
.assoc
= NULL
;
1357 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1358 ptr2
->ts
.type
= BT_DERIVED
;
1359 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1360 ptr2
->attr
.flavor
= FL_VARIABLE
;
1361 ptr2
->attr
.pointer
= 1;
1362 ptr2
->attr
.artificial
= 1;
1363 gfc_set_sym_referenced (ptr2
);
1364 gfc_commit_symbol (ptr2
);
1366 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1367 tmp_array
->ts
.type
= BT_DERIVED
;
1368 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1369 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1370 tmp_array
->attr
.dimension
= 1;
1371 tmp_array
->attr
.artificial
= 1;
1372 tmp_array
->as
= gfc_get_array_spec();
1373 tmp_array
->attr
.intent
= INTENT_INOUT
;
1374 tmp_array
->as
->type
= AS_EXPLICIT
;
1375 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1377 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1379 gfc_expr
*shape_expr
;
1380 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1382 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1384 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1385 gfc_current_locus
, 3,
1386 gfc_lval_expr_from_sym (array
),
1387 gfc_get_int_expr (gfc_default_integer_kind
,
1389 gfc_get_int_expr (gfc_default_integer_kind
,
1391 gfc_index_integer_kind
));
1392 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1393 tmp_array
->as
->upper
[i
] = shape_expr
;
1395 gfc_set_sym_referenced (tmp_array
);
1396 gfc_commit_symbol (tmp_array
);
1399 iter
= gfc_get_iterator ();
1400 iter
->var
= gfc_lval_expr_from_sym (idx
);
1401 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1402 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1403 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1405 block
= gfc_get_code (EXEC_DO
);
1407 block
->ext
.iterator
= iter
;
1408 block
->block
= gfc_get_code (EXEC_DO
);
1410 /* Offset calculation for the new array: idx * size of type (in bytes). */
1411 offset2
= gfc_get_expr ();
1412 offset2
->expr_type
= EXPR_OP
;
1413 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1414 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1415 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1416 offset2
->ts
= byte_stride
->ts
;
1418 /* Offset calculation of "array". */
1419 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1420 byte_stride
, rank
, block
->block
, sub_ns
);
1423 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1424 + idx * stride, c_ptr), ptr). */
1425 block2
->next
= finalization_scalarizer (array
, ptr
,
1426 gfc_lval_expr_from_sym (offset
),
1428 block2
= block2
->next
;
1429 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1430 block2
= block2
->next
;
1433 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1434 block2
= block2
->next
;
1435 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1436 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1438 /* Call now the user's final subroutine. */
1439 block
->next
= gfc_get_code (EXEC_CALL
);
1440 block
= block
->next
;
1441 block
->symtree
= fini
->proc_tree
;
1442 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1443 block
->ext
.actual
= gfc_get_actual_arglist ();
1444 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1446 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1452 iter
= gfc_get_iterator ();
1453 iter
->var
= gfc_lval_expr_from_sym (idx
);
1454 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1455 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1456 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1458 block
->next
= gfc_get_code (EXEC_DO
);
1459 block
= block
->next
;
1460 block
->ext
.iterator
= iter
;
1461 block
->block
= gfc_get_code (EXEC_DO
);
1463 /* Offset calculation of "array". */
1464 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1465 byte_stride
, rank
, block
->block
, sub_ns
);
1468 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1469 + offset, c_ptr), ptr). */
1470 block2
->next
= finalization_scalarizer (array
, ptr
,
1471 gfc_lval_expr_from_sym (offset
),
1473 block2
= block2
->next
;
1474 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1475 gfc_copy_expr (offset2
), sub_ns
);
1476 block2
= block2
->next
;
1479 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1480 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1481 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1485 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1486 derived type "derived". The function first calls the approriate FINAL
1487 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1488 components (but not the inherited ones). Last, it calls the wrapper
1489 subroutine of the parent. The generated wrapper procedure takes as argument
1490 an assumed-rank array.
1491 If neither allocatable components nor FINAL subroutines exists, the vtab
1492 will contain a NULL pointer.
1493 The generated function has the form
1494 _final(assumed-rank array, stride, skip_corarray)
1495 where the array has to be contiguous (except of the lowest dimension). The
1496 stride (in bytes) is used to allow different sizes for ancestor types by
1497 skipping over the additionally added components in the scalarizer. If
1498 "fini_coarray" is false, coarray components are not finalized to allow for
1499 the correct semantic with intrinsic assignment. */
1502 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1503 const char *tname
, gfc_component
*vtab_final
)
1505 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1506 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1507 gfc_component
*comp
;
1508 gfc_namespace
*sub_ns
;
1509 gfc_code
*last_code
, *block
;
1510 char name
[GFC_MAX_SYMBOL_LEN
+1];
1511 bool finalizable_comp
= false;
1512 bool expr_null_wrapper
= false;
1513 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1516 if (derived
->attr
.unlimited_polymorphic
)
1518 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1522 /* Search for the ancestor's finalizers. */
1523 if (derived
->attr
.extension
&& derived
->components
1524 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1525 || has_finalizer_component (derived
)))
1528 gfc_component
*comp
;
1530 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1531 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1532 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1534 ancestor_wrapper
= comp
->initializer
;
1539 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1540 components: Return a NULL() expression; we defer this a bit to have have
1541 an interface declaration. */
1542 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1543 && !derived
->attr
.alloc_comp
1544 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1545 && !has_finalizer_component (derived
))
1546 expr_null_wrapper
= true;
1548 /* Check whether there are new allocatable components. */
1549 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1551 if (comp
== derived
->components
&& derived
->attr
.extension
1552 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1555 finalizable_comp
|= comp_is_finalizable (comp
);
1558 /* If there is no new finalizer and no new allocatable, return with
1559 an expr to the ancestor's one. */
1560 if (!expr_null_wrapper
&& !finalizable_comp
1561 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1563 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1564 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1565 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1566 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1570 /* We now create a wrapper, which does the following:
1571 1. Call the suitable finalization subroutine for this type
1572 2. Loop over all noninherited allocatable components and noninherited
1573 components with allocatable components and DEALLOCATE those; this will
1574 take care of finalizers, coarray deregistering and allocatable
1576 3. Call the ancestor's finalizer. */
1578 /* Declare the wrapper function; it takes an assumed-rank array
1579 and a VALUE logical as arguments. */
1581 /* Set up the namespace. */
1582 sub_ns
= gfc_get_namespace (ns
, 0);
1583 sub_ns
->sibling
= ns
->contained
;
1584 if (!expr_null_wrapper
)
1585 ns
->contained
= sub_ns
;
1586 sub_ns
->resolved
= 1;
1588 /* Set up the procedure symbol. */
1589 sprintf (name
, "__final_%s", tname
);
1590 gfc_get_symbol (name
, sub_ns
, &final
);
1591 sub_ns
->proc_name
= final
;
1592 final
->attr
.flavor
= FL_PROCEDURE
;
1593 final
->attr
.function
= 1;
1594 final
->attr
.pure
= 0;
1595 final
->result
= final
;
1596 final
->ts
.type
= BT_INTEGER
;
1598 final
->attr
.artificial
= 1;
1599 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1600 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1601 final
->module
= ns
->proc_name
->name
;
1602 gfc_set_sym_referenced (final
);
1603 gfc_commit_symbol (final
);
1605 /* Set up formal argument. */
1606 gfc_get_symbol ("array", sub_ns
, &array
);
1607 array
->ts
.type
= BT_DERIVED
;
1608 array
->ts
.u
.derived
= derived
;
1609 array
->attr
.flavor
= FL_VARIABLE
;
1610 array
->attr
.dummy
= 1;
1611 array
->attr
.contiguous
= 1;
1612 array
->attr
.dimension
= 1;
1613 array
->attr
.artificial
= 1;
1614 array
->as
= gfc_get_array_spec();
1615 array
->as
->type
= AS_ASSUMED_RANK
;
1616 array
->as
->rank
= -1;
1617 array
->attr
.intent
= INTENT_INOUT
;
1618 gfc_set_sym_referenced (array
);
1619 final
->formal
= gfc_get_formal_arglist ();
1620 final
->formal
->sym
= array
;
1621 gfc_commit_symbol (array
);
1623 /* Set up formal argument. */
1624 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1625 byte_stride
->ts
.type
= BT_INTEGER
;
1626 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1627 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1628 byte_stride
->attr
.dummy
= 1;
1629 byte_stride
->attr
.value
= 1;
1630 byte_stride
->attr
.artificial
= 1;
1631 gfc_set_sym_referenced (byte_stride
);
1632 final
->formal
->next
= gfc_get_formal_arglist ();
1633 final
->formal
->next
->sym
= byte_stride
;
1634 gfc_commit_symbol (byte_stride
);
1636 /* Set up formal argument. */
1637 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1638 fini_coarray
->ts
.type
= BT_LOGICAL
;
1639 fini_coarray
->ts
.kind
= 1;
1640 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1641 fini_coarray
->attr
.dummy
= 1;
1642 fini_coarray
->attr
.value
= 1;
1643 fini_coarray
->attr
.artificial
= 1;
1644 gfc_set_sym_referenced (fini_coarray
);
1645 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1646 final
->formal
->next
->next
->sym
= fini_coarray
;
1647 gfc_commit_symbol (fini_coarray
);
1649 /* Return with a NULL() expression but with an interface which has
1650 the formal arguments. */
1651 if (expr_null_wrapper
)
1653 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1654 vtab_final
->ts
.interface
= final
;
1658 /* Local variables. */
1660 gfc_get_symbol ("idx", sub_ns
, &idx
);
1661 idx
->ts
.type
= BT_INTEGER
;
1662 idx
->ts
.kind
= gfc_index_integer_kind
;
1663 idx
->attr
.flavor
= FL_VARIABLE
;
1664 idx
->attr
.artificial
= 1;
1665 gfc_set_sym_referenced (idx
);
1666 gfc_commit_symbol (idx
);
1668 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1669 idx2
->ts
.type
= BT_INTEGER
;
1670 idx2
->ts
.kind
= gfc_index_integer_kind
;
1671 idx2
->attr
.flavor
= FL_VARIABLE
;
1672 idx2
->attr
.artificial
= 1;
1673 gfc_set_sym_referenced (idx2
);
1674 gfc_commit_symbol (idx2
);
1676 gfc_get_symbol ("offset", sub_ns
, &offset
);
1677 offset
->ts
.type
= BT_INTEGER
;
1678 offset
->ts
.kind
= gfc_index_integer_kind
;
1679 offset
->attr
.flavor
= FL_VARIABLE
;
1680 offset
->attr
.artificial
= 1;
1681 gfc_set_sym_referenced (offset
);
1682 gfc_commit_symbol (offset
);
1684 /* Create RANK expression. */
1685 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1686 gfc_current_locus
, 1,
1687 gfc_lval_expr_from_sym (array
));
1688 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1689 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1691 /* Create is_contiguous variable. */
1692 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1693 is_contiguous
->ts
.type
= BT_LOGICAL
;
1694 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1695 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1696 is_contiguous
->attr
.artificial
= 1;
1697 gfc_set_sym_referenced (is_contiguous
);
1698 gfc_commit_symbol (is_contiguous
);
1700 /* Create "sizes(0..rank)" variable, which contains the multiplied
1701 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1702 sizes(2) = sizes(1) * extent(dim=2) etc. */
1703 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1704 sizes
->ts
.type
= BT_INTEGER
;
1705 sizes
->ts
.kind
= gfc_index_integer_kind
;
1706 sizes
->attr
.flavor
= FL_VARIABLE
;
1707 sizes
->attr
.dimension
= 1;
1708 sizes
->attr
.artificial
= 1;
1709 sizes
->as
= gfc_get_array_spec();
1710 sizes
->attr
.intent
= INTENT_INOUT
;
1711 sizes
->as
->type
= AS_EXPLICIT
;
1712 sizes
->as
->rank
= 1;
1713 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1714 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1715 gfc_set_sym_referenced (sizes
);
1716 gfc_commit_symbol (sizes
);
1718 /* Create "strides(1..rank)" variable, which contains the strides per
1720 gfc_get_symbol ("strides", sub_ns
, &strides
);
1721 strides
->ts
.type
= BT_INTEGER
;
1722 strides
->ts
.kind
= gfc_index_integer_kind
;
1723 strides
->attr
.flavor
= FL_VARIABLE
;
1724 strides
->attr
.dimension
= 1;
1725 strides
->attr
.artificial
= 1;
1726 strides
->as
= gfc_get_array_spec();
1727 strides
->attr
.intent
= INTENT_INOUT
;
1728 strides
->as
->type
= AS_EXPLICIT
;
1729 strides
->as
->rank
= 1;
1730 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1731 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1732 gfc_set_sym_referenced (strides
);
1733 gfc_commit_symbol (strides
);
1736 /* Set return value to 0. */
1737 last_code
= gfc_get_code (EXEC_ASSIGN
);
1738 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1739 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1740 sub_ns
->code
= last_code
;
1742 /* Set: is_contiguous = .true. */
1743 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1744 last_code
= last_code
->next
;
1745 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1746 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1747 &gfc_current_locus
, true);
1749 /* Set: sizes(0) = 1. */
1750 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1751 last_code
= last_code
->next
;
1752 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1753 last_code
->expr1
->ref
= gfc_get_ref ();
1754 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1755 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1756 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1757 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1758 last_code
->expr1
->ref
->u
.ar
.start
[0]
1759 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1760 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1761 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1765 strides(idx) = _F._stride (array, dim=idx)
1766 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1767 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1771 iter
= gfc_get_iterator ();
1772 iter
->var
= gfc_lval_expr_from_sym (idx
);
1773 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1774 iter
->end
= gfc_copy_expr (rank
);
1775 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1776 last_code
->next
= gfc_get_code (EXEC_DO
);
1777 last_code
= last_code
->next
;
1778 last_code
->ext
.iterator
= iter
;
1779 last_code
->block
= gfc_get_code (EXEC_DO
);
1781 /* strides(idx) = _F._stride(array,dim=idx). */
1782 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1783 block
= last_code
->block
->next
;
1785 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1786 block
->expr1
->ref
= gfc_get_ref ();
1787 block
->expr1
->ref
->type
= REF_ARRAY
;
1788 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1789 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1790 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1791 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1792 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1794 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1795 gfc_current_locus
, 2,
1796 gfc_lval_expr_from_sym (array
),
1797 gfc_lval_expr_from_sym (idx
));
1799 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1800 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1801 block
= block
->next
;
1803 /* sizes(idx) = ... */
1804 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1805 block
->expr1
->ref
= gfc_get_ref ();
1806 block
->expr1
->ref
->type
= REF_ARRAY
;
1807 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1808 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1809 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1810 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1811 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1813 block
->expr2
= gfc_get_expr ();
1814 block
->expr2
->expr_type
= EXPR_OP
;
1815 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1818 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1819 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1820 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1821 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1822 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1823 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1824 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1825 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1826 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1827 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1828 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1829 = gfc_lval_expr_from_sym (idx
);
1830 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1831 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1832 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1833 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1835 /* size(array, dim=idx, kind=index_kind). */
1836 block
->expr2
->value
.op
.op2
1837 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1838 gfc_current_locus
, 3,
1839 gfc_lval_expr_from_sym (array
),
1840 gfc_lval_expr_from_sym (idx
),
1841 gfc_get_int_expr (gfc_index_integer_kind
,
1843 gfc_index_integer_kind
));
1844 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1845 block
->expr2
->ts
= idx
->ts
;
1847 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1848 block
->next
= gfc_get_code (EXEC_IF
);
1849 block
= block
->next
;
1851 block
->block
= gfc_get_code (EXEC_IF
);
1852 block
= block
->block
;
1854 /* if condition: strides(idx) /= sizes(idx-1). */
1855 block
->expr1
= gfc_get_expr ();
1856 block
->expr1
->ts
.type
= BT_LOGICAL
;
1857 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1858 block
->expr1
->expr_type
= EXPR_OP
;
1859 block
->expr1
->where
= gfc_current_locus
;
1860 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1862 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1863 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1864 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1865 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1866 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1867 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1868 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1869 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1871 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1872 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1873 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1874 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1875 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1876 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1877 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1878 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1879 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1880 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1881 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1882 = gfc_lval_expr_from_sym (idx
);
1883 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1884 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1885 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1886 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1888 /* if body: is_contiguous = .false. */
1889 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1890 block
= block
->next
;
1891 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1892 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1893 &gfc_current_locus
, false);
1895 /* Obtain the size (number of elements) of "array" MINUS ONE,
1896 which is used in the scalarization. */
1897 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1898 nelem
->ts
.type
= BT_INTEGER
;
1899 nelem
->ts
.kind
= gfc_index_integer_kind
;
1900 nelem
->attr
.flavor
= FL_VARIABLE
;
1901 nelem
->attr
.artificial
= 1;
1902 gfc_set_sym_referenced (nelem
);
1903 gfc_commit_symbol (nelem
);
1905 /* nelem = sizes (rank) - 1. */
1906 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1907 last_code
= last_code
->next
;
1909 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1911 last_code
->expr2
= gfc_get_expr ();
1912 last_code
->expr2
->expr_type
= EXPR_OP
;
1913 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1914 last_code
->expr2
->value
.op
.op2
1915 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1916 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1918 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1919 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1920 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1921 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1922 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1923 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1924 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1925 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1927 /* Call final subroutines. We now generate code like:
1929 integer, pointer :: ptr
1931 integer(c_intptr_t) :: i, addr
1933 select case (rank (array))
1935 ! If needed, the array is packed
1936 call final_rank3 (array)
1938 do i = 0, size (array)-1
1939 addr = transfer (c_loc (array), addr) + i * stride
1940 call c_f_pointer (transfer (addr, cptr), ptr)
1941 call elemental_final (ptr)
1945 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1947 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1949 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1950 ptr
->ts
.type
= BT_DERIVED
;
1951 ptr
->ts
.u
.derived
= derived
;
1952 ptr
->attr
.flavor
= FL_VARIABLE
;
1953 ptr
->attr
.pointer
= 1;
1954 ptr
->attr
.artificial
= 1;
1955 gfc_set_sym_referenced (ptr
);
1956 gfc_commit_symbol (ptr
);
1958 /* SELECT CASE (RANK (array)). */
1959 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1960 last_code
= last_code
->next
;
1961 last_code
->expr1
= gfc_copy_expr (rank
);
1964 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1966 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1967 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1973 /* CASE (fini_rank). */
1976 block
->block
= gfc_get_code (EXEC_SELECT
);
1977 block
= block
->block
;
1981 block
= gfc_get_code (EXEC_SELECT
);
1982 last_code
->block
= block
;
1984 block
->ext
.block
.case_list
= gfc_get_case ();
1985 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1986 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1987 block
->ext
.block
.case_list
->low
1988 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1989 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1991 block
->ext
.block
.case_list
->low
1992 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1993 block
->ext
.block
.case_list
->high
1994 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
1996 /* CALL fini_rank (array) - possibly with packing. */
1997 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1998 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1999 idx
, ptr
, nelem
, strides
,
2000 sizes
, idx2
, offset
, is_contiguous
,
2004 block
->next
= gfc_get_code (EXEC_CALL
);
2005 block
->next
->symtree
= fini
->proc_tree
;
2006 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2007 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2008 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2012 /* Elemental call - scalarized. */
2018 block
->block
= gfc_get_code (EXEC_SELECT
);
2019 block
= block
->block
;
2023 block
= gfc_get_code (EXEC_SELECT
);
2024 last_code
->block
= block
;
2026 block
->ext
.block
.case_list
= gfc_get_case ();
2029 iter
= gfc_get_iterator ();
2030 iter
->var
= gfc_lval_expr_from_sym (idx
);
2031 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2032 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2033 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2034 block
->next
= gfc_get_code (EXEC_DO
);
2035 block
= block
->next
;
2036 block
->ext
.iterator
= iter
;
2037 block
->block
= gfc_get_code (EXEC_DO
);
2039 /* Offset calculation. */
2040 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2041 byte_stride
, rank
, block
->block
,
2045 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2046 + offset, c_ptr), ptr). */
2048 = finalization_scalarizer (array
, ptr
,
2049 gfc_lval_expr_from_sym (offset
),
2051 block
= block
->next
;
2053 /* CALL final_elemental (array). */
2054 block
->next
= gfc_get_code (EXEC_CALL
);
2055 block
= block
->next
;
2056 block
->symtree
= fini_elem
->proc_tree
;
2057 block
->resolved_sym
= fini_elem
->proc_sym
;
2058 block
->ext
.actual
= gfc_get_actual_arglist ();
2059 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2063 /* Finalize and deallocate allocatable components. The same manual
2064 scalarization is used as above. */
2066 if (finalizable_comp
)
2069 gfc_code
*block
= NULL
;
2073 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2074 ptr
->ts
.type
= BT_DERIVED
;
2075 ptr
->ts
.u
.derived
= derived
;
2076 ptr
->attr
.flavor
= FL_VARIABLE
;
2077 ptr
->attr
.pointer
= 1;
2078 ptr
->attr
.artificial
= 1;
2079 gfc_set_sym_referenced (ptr
);
2080 gfc_commit_symbol (ptr
);
2083 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2084 stat
->attr
.flavor
= FL_VARIABLE
;
2085 stat
->attr
.artificial
= 1;
2086 stat
->ts
.type
= BT_INTEGER
;
2087 stat
->ts
.kind
= gfc_default_integer_kind
;
2088 gfc_set_sym_referenced (stat
);
2089 gfc_commit_symbol (stat
);
2092 iter
= gfc_get_iterator ();
2093 iter
->var
= gfc_lval_expr_from_sym (idx
);
2094 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2095 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2096 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2097 last_code
->next
= gfc_get_code (EXEC_DO
);
2098 last_code
= last_code
->next
;
2099 last_code
->ext
.iterator
= iter
;
2100 last_code
->block
= gfc_get_code (EXEC_DO
);
2102 /* Offset calculation. */
2103 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2104 byte_stride
, rank
, last_code
->block
,
2108 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2109 + idx * stride, c_ptr), ptr). */
2110 block
->next
= finalization_scalarizer (array
, ptr
,
2111 gfc_lval_expr_from_sym(offset
),
2113 block
= block
->next
;
2115 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2117 if (comp
== derived
->components
&& derived
->attr
.extension
2118 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2121 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2122 stat
, fini_coarray
, &block
, sub_ns
);
2123 if (!last_code
->block
->next
)
2124 last_code
->block
->next
= block
;
2129 /* Call the finalizer of the ancestor. */
2130 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2132 last_code
->next
= gfc_get_code (EXEC_CALL
);
2133 last_code
= last_code
->next
;
2134 last_code
->symtree
= ancestor_wrapper
->symtree
;
2135 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2137 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2138 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2139 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2140 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2141 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2142 last_code
->ext
.actual
->next
->next
->expr
2143 = gfc_lval_expr_from_sym (fini_coarray
);
2146 gfc_free_expr (rank
);
2147 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2148 vtab_final
->ts
.interface
= final
;
2152 /* Add procedure pointers for all type-bound procedures to a vtab. */
2155 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2157 gfc_symbol
* super_type
;
2159 super_type
= gfc_get_derived_super_type (derived
);
2161 if (super_type
&& (super_type
!= derived
))
2163 /* Make sure that the PPCs appear in the same order as in the parent. */
2164 copy_vtab_proc_comps (super_type
, vtype
);
2165 /* Only needed to get the PPC initializers right. */
2166 add_procs_to_declared_vtab (super_type
, vtype
);
2169 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2170 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2172 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2173 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2177 /* Find or generate the symbol for a derived type's vtab. */
2180 gfc_find_derived_vtab (gfc_symbol
*derived
)
2183 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2184 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2186 /* Find the top-level namespace. */
2187 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2191 /* If the type is a class container, use the underlying derived type. */
2192 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2193 derived
= gfc_get_derived_super_type (derived
);
2197 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2199 get_unique_hashed_string (tname
, derived
);
2200 sprintf (name
, "__vtab_%s", tname
);
2202 /* Look for the vtab symbol in various namespaces. */
2203 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2205 gfc_find_symbol (name
, ns
, 0, &vtab
);
2207 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2211 gfc_get_symbol (name
, ns
, &vtab
);
2212 vtab
->ts
.type
= BT_DERIVED
;
2213 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2214 &gfc_current_locus
))
2216 vtab
->attr
.target
= 1;
2217 vtab
->attr
.save
= SAVE_IMPLICIT
;
2218 vtab
->attr
.vtab
= 1;
2219 vtab
->attr
.access
= ACCESS_PUBLIC
;
2220 gfc_set_sym_referenced (vtab
);
2221 sprintf (name
, "__vtype_%s", tname
);
2223 gfc_find_symbol (name
, ns
, 0, &vtype
);
2227 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2229 gfc_get_symbol (name
, ns
, &vtype
);
2230 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2231 &gfc_current_locus
))
2233 vtype
->attr
.access
= ACCESS_PUBLIC
;
2234 vtype
->attr
.vtype
= 1;
2235 gfc_set_sym_referenced (vtype
);
2237 /* Add component '_hash'. */
2238 if (!gfc_add_component (vtype
, "_hash", &c
))
2240 c
->ts
.type
= BT_INTEGER
;
2242 c
->attr
.access
= ACCESS_PRIVATE
;
2243 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2244 NULL
, derived
->hash_value
);
2246 /* Add component '_size'. */
2247 if (!gfc_add_component (vtype
, "_size", &c
))
2249 c
->ts
.type
= BT_INTEGER
;
2251 c
->attr
.access
= ACCESS_PRIVATE
;
2252 /* Remember the derived type in ts.u.derived,
2253 so that the correct initializer can be set later on
2254 (in gfc_conv_structure). */
2255 c
->ts
.u
.derived
= derived
;
2256 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2259 /* Add component _extends. */
2260 if (!gfc_add_component (vtype
, "_extends", &c
))
2262 c
->attr
.pointer
= 1;
2263 c
->attr
.access
= ACCESS_PRIVATE
;
2264 if (!derived
->attr
.unlimited_polymorphic
)
2265 parent
= gfc_get_derived_super_type (derived
);
2271 parent_vtab
= gfc_find_derived_vtab (parent
);
2272 c
->ts
.type
= BT_DERIVED
;
2273 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2274 c
->initializer
= gfc_get_expr ();
2275 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2276 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2277 0, &c
->initializer
->symtree
);
2281 c
->ts
.type
= BT_DERIVED
;
2282 c
->ts
.u
.derived
= vtype
;
2283 c
->initializer
= gfc_get_null_expr (NULL
);
2286 if (!derived
->attr
.unlimited_polymorphic
2287 && derived
->components
== NULL
2288 && !derived
->attr
.zero_comp
)
2290 /* At this point an error must have occurred.
2291 Prevent further errors on the vtype components. */
2296 /* Add component _def_init. */
2297 if (!gfc_add_component (vtype
, "_def_init", &c
))
2299 c
->attr
.pointer
= 1;
2300 c
->attr
.artificial
= 1;
2301 c
->attr
.access
= ACCESS_PRIVATE
;
2302 c
->ts
.type
= BT_DERIVED
;
2303 c
->ts
.u
.derived
= derived
;
2304 if (derived
->attr
.unlimited_polymorphic
2305 || derived
->attr
.abstract
)
2306 c
->initializer
= gfc_get_null_expr (NULL
);
2309 /* Construct default initialization variable. */
2310 sprintf (name
, "__def_init_%s", tname
);
2311 gfc_get_symbol (name
, ns
, &def_init
);
2312 def_init
->attr
.target
= 1;
2313 def_init
->attr
.artificial
= 1;
2314 def_init
->attr
.save
= SAVE_IMPLICIT
;
2315 def_init
->attr
.access
= ACCESS_PUBLIC
;
2316 def_init
->attr
.flavor
= FL_VARIABLE
;
2317 gfc_set_sym_referenced (def_init
);
2318 def_init
->ts
.type
= BT_DERIVED
;
2319 def_init
->ts
.u
.derived
= derived
;
2320 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2322 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2325 /* Add component _copy. */
2326 if (!gfc_add_component (vtype
, "_copy", &c
))
2328 c
->attr
.proc_pointer
= 1;
2329 c
->attr
.access
= ACCESS_PRIVATE
;
2330 c
->tb
= XCNEW (gfc_typebound_proc
);
2332 if (derived
->attr
.unlimited_polymorphic
2333 || derived
->attr
.abstract
)
2334 c
->initializer
= gfc_get_null_expr (NULL
);
2337 /* Set up namespace. */
2338 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2339 sub_ns
->sibling
= ns
->contained
;
2340 ns
->contained
= sub_ns
;
2341 sub_ns
->resolved
= 1;
2342 /* Set up procedure symbol. */
2343 sprintf (name
, "__copy_%s", tname
);
2344 gfc_get_symbol (name
, sub_ns
, ©
);
2345 sub_ns
->proc_name
= copy
;
2346 copy
->attr
.flavor
= FL_PROCEDURE
;
2347 copy
->attr
.subroutine
= 1;
2348 copy
->attr
.pure
= 1;
2349 copy
->attr
.artificial
= 1;
2350 copy
->attr
.if_source
= IFSRC_DECL
;
2351 /* This is elemental so that arrays are automatically
2352 treated correctly by the scalarizer. */
2353 copy
->attr
.elemental
= 1;
2354 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2355 copy
->module
= ns
->proc_name
->name
;
2356 gfc_set_sym_referenced (copy
);
2357 /* Set up formal arguments. */
2358 gfc_get_symbol ("src", sub_ns
, &src
);
2359 src
->ts
.type
= BT_DERIVED
;
2360 src
->ts
.u
.derived
= derived
;
2361 src
->attr
.flavor
= FL_VARIABLE
;
2362 src
->attr
.dummy
= 1;
2363 src
->attr
.artificial
= 1;
2364 src
->attr
.intent
= INTENT_IN
;
2365 gfc_set_sym_referenced (src
);
2366 copy
->formal
= gfc_get_formal_arglist ();
2367 copy
->formal
->sym
= src
;
2368 gfc_get_symbol ("dst", sub_ns
, &dst
);
2369 dst
->ts
.type
= BT_DERIVED
;
2370 dst
->ts
.u
.derived
= derived
;
2371 dst
->attr
.flavor
= FL_VARIABLE
;
2372 dst
->attr
.dummy
= 1;
2373 dst
->attr
.artificial
= 1;
2374 dst
->attr
.intent
= INTENT_INOUT
;
2375 gfc_set_sym_referenced (dst
);
2376 copy
->formal
->next
= gfc_get_formal_arglist ();
2377 copy
->formal
->next
->sym
= dst
;
2379 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2380 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2381 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2382 /* Set initializer. */
2383 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2384 c
->ts
.interface
= copy
;
2387 /* Add component _final, which contains a procedure pointer to
2388 a wrapper which handles both the freeing of allocatable
2389 components and the calls to finalization subroutines.
2390 Note: The actual wrapper function can only be generated
2391 at resolution time. */
2392 if (!gfc_add_component (vtype
, "_final", &c
))
2394 c
->attr
.proc_pointer
= 1;
2395 c
->attr
.access
= ACCESS_PRIVATE
;
2396 c
->tb
= XCNEW (gfc_typebound_proc
);
2398 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2400 /* Add procedure pointers for type-bound procedures. */
2401 if (!derived
->attr
.unlimited_polymorphic
)
2402 add_procs_to_declared_vtab (derived
, vtype
);
2406 vtab
->ts
.u
.derived
= vtype
;
2407 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2414 /* It is unexpected to have some symbols added at resolution or code
2415 generation time. We commit the changes in order to keep a clean state. */
2418 gfc_commit_symbol (vtab
);
2420 gfc_commit_symbol (vtype
);
2422 gfc_commit_symbol (def_init
);
2424 gfc_commit_symbol (copy
);
2426 gfc_commit_symbol (src
);
2428 gfc_commit_symbol (dst
);
2431 gfc_undo_symbols ();
2437 /* Check if a derived type is finalizable. That is the case if it
2438 (1) has a FINAL subroutine or
2439 (2) has a nonpointer nonallocatable component of finalizable type.
2440 If it is finalizable, return an expression containing the
2441 finalization wrapper. */
2444 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2449 /* (1) Check for FINAL subroutines. */
2450 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2453 /* (2) Check for components of finalizable type. */
2454 for (c
= derived
->components
; c
; c
= c
->next
)
2455 if (c
->ts
.type
== BT_DERIVED
2456 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2457 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2463 /* Make sure vtab is generated. */
2464 vtab
= gfc_find_derived_vtab (derived
);
2467 /* Return finalizer expression. */
2468 gfc_component
*final
;
2469 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2470 gcc_assert (strcmp (final
->name
, "_final") == 0);
2471 gcc_assert (final
->initializer
2472 && final
->initializer
->expr_type
!= EXPR_NULL
);
2473 *final_expr
= final
->initializer
;
2479 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2480 needed to support unlimited polymorphism. */
2483 find_intrinsic_vtab (gfc_typespec
*ts
)
2486 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2487 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2490 if (ts
->type
== BT_CHARACTER
&& !ts
->deferred
&& ts
->u
.cl
&& ts
->u
.cl
->length
2491 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2492 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2494 /* Find the top-level namespace. */
2495 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2501 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2503 if (ts
->type
== BT_CHARACTER
)
2504 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2507 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2509 sprintf (name
, "__vtab_%s", tname
);
2511 /* Look for the vtab symbol in various namespaces. */
2512 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2514 gfc_find_symbol (name
, ns
, 0, &vtab
);
2518 gfc_get_symbol (name
, ns
, &vtab
);
2519 vtab
->ts
.type
= BT_DERIVED
;
2520 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2521 &gfc_current_locus
))
2523 vtab
->attr
.target
= 1;
2524 vtab
->attr
.save
= SAVE_IMPLICIT
;
2525 vtab
->attr
.vtab
= 1;
2526 vtab
->attr
.access
= ACCESS_PUBLIC
;
2527 gfc_set_sym_referenced (vtab
);
2528 sprintf (name
, "__vtype_%s", tname
);
2530 gfc_find_symbol (name
, ns
, 0, &vtype
);
2535 gfc_namespace
*sub_ns
;
2536 gfc_namespace
*contained
;
2539 gfc_get_symbol (name
, ns
, &vtype
);
2540 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2541 &gfc_current_locus
))
2543 vtype
->attr
.access
= ACCESS_PUBLIC
;
2544 vtype
->attr
.vtype
= 1;
2545 gfc_set_sym_referenced (vtype
);
2547 /* Add component '_hash'. */
2548 if (!gfc_add_component (vtype
, "_hash", &c
))
2550 c
->ts
.type
= BT_INTEGER
;
2552 c
->attr
.access
= ACCESS_PRIVATE
;
2553 hash
= gfc_intrinsic_hash_value (ts
);
2554 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2557 /* Add component '_size'. */
2558 if (!gfc_add_component (vtype
, "_size", &c
))
2560 c
->ts
.type
= BT_INTEGER
;
2562 c
->attr
.access
= ACCESS_PRIVATE
;
2564 /* Build a minimal expression to make use of
2565 target-memory.c/gfc_element_size for 'size'. */
2566 e
= gfc_get_expr ();
2568 e
->expr_type
= EXPR_VARIABLE
;
2569 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2571 (int)gfc_element_size (e
));
2574 /* Add component _extends. */
2575 if (!gfc_add_component (vtype
, "_extends", &c
))
2577 c
->attr
.pointer
= 1;
2578 c
->attr
.access
= ACCESS_PRIVATE
;
2579 c
->ts
.type
= BT_VOID
;
2580 c
->initializer
= gfc_get_null_expr (NULL
);
2582 /* Add component _def_init. */
2583 if (!gfc_add_component (vtype
, "_def_init", &c
))
2585 c
->attr
.pointer
= 1;
2586 c
->attr
.access
= ACCESS_PRIVATE
;
2587 c
->ts
.type
= BT_VOID
;
2588 c
->initializer
= gfc_get_null_expr (NULL
);
2590 /* Add component _copy. */
2591 if (!gfc_add_component (vtype
, "_copy", &c
))
2593 c
->attr
.proc_pointer
= 1;
2594 c
->attr
.access
= ACCESS_PRIVATE
;
2595 c
->tb
= XCNEW (gfc_typebound_proc
);
2598 if (ts
->type
!= BT_CHARACTER
)
2599 sprintf (name
, "__copy_%s", tname
);
2602 /* __copy is always the same for characters.
2603 Check to see if copy function already exists. */
2604 sprintf (name
, "__copy_character_%d", ts
->kind
);
2605 contained
= ns
->contained
;
2606 for (; contained
; contained
= contained
->sibling
)
2607 if (contained
->proc_name
2608 && strcmp (name
, contained
->proc_name
->name
) == 0)
2610 copy
= contained
->proc_name
;
2615 /* Set up namespace. */
2616 sub_ns
= gfc_get_namespace (ns
, 0);
2617 sub_ns
->sibling
= ns
->contained
;
2618 ns
->contained
= sub_ns
;
2619 sub_ns
->resolved
= 1;
2620 /* Set up procedure symbol. */
2621 gfc_get_symbol (name
, sub_ns
, ©
);
2622 sub_ns
->proc_name
= copy
;
2623 copy
->attr
.flavor
= FL_PROCEDURE
;
2624 copy
->attr
.subroutine
= 1;
2625 copy
->attr
.pure
= 1;
2626 copy
->attr
.if_source
= IFSRC_DECL
;
2627 /* This is elemental so that arrays are automatically
2628 treated correctly by the scalarizer. */
2629 copy
->attr
.elemental
= 1;
2630 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2631 copy
->module
= ns
->proc_name
->name
;
2632 gfc_set_sym_referenced (copy
);
2633 /* Set up formal arguments. */
2634 gfc_get_symbol ("src", sub_ns
, &src
);
2635 src
->ts
.type
= ts
->type
;
2636 src
->ts
.kind
= ts
->kind
;
2637 src
->attr
.flavor
= FL_VARIABLE
;
2638 src
->attr
.dummy
= 1;
2639 src
->attr
.intent
= INTENT_IN
;
2640 gfc_set_sym_referenced (src
);
2641 copy
->formal
= gfc_get_formal_arglist ();
2642 copy
->formal
->sym
= src
;
2643 gfc_get_symbol ("dst", sub_ns
, &dst
);
2644 dst
->ts
.type
= ts
->type
;
2645 dst
->ts
.kind
= ts
->kind
;
2646 dst
->attr
.flavor
= FL_VARIABLE
;
2647 dst
->attr
.dummy
= 1;
2648 dst
->attr
.intent
= INTENT_INOUT
;
2649 gfc_set_sym_referenced (dst
);
2650 copy
->formal
->next
= gfc_get_formal_arglist ();
2651 copy
->formal
->next
->sym
= dst
;
2653 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2654 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2655 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2657 /* Set initializer. */
2658 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2659 c
->ts
.interface
= copy
;
2661 /* Add component _final. */
2662 if (!gfc_add_component (vtype
, "_final", &c
))
2664 c
->attr
.proc_pointer
= 1;
2665 c
->attr
.access
= ACCESS_PRIVATE
;
2666 c
->tb
= XCNEW (gfc_typebound_proc
);
2668 c
->initializer
= gfc_get_null_expr (NULL
);
2670 vtab
->ts
.u
.derived
= vtype
;
2671 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2678 /* It is unexpected to have some symbols added at resolution or code
2679 generation time. We commit the changes in order to keep a clean state. */
2682 gfc_commit_symbol (vtab
);
2684 gfc_commit_symbol (vtype
);
2686 gfc_commit_symbol (copy
);
2688 gfc_commit_symbol (src
);
2690 gfc_commit_symbol (dst
);
2693 gfc_undo_symbols ();
2699 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2702 gfc_find_vtab (gfc_typespec
*ts
)
2709 return gfc_find_derived_vtab (ts
->u
.derived
);
2711 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2713 return find_intrinsic_vtab (ts
);
2718 /* General worker function to find either a type-bound procedure or a
2719 type-bound user operator. */
2722 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2723 const char* name
, bool noaccess
, bool uop
,
2729 /* Set default to failure. */
2733 if (derived
->f2k_derived
)
2734 /* Set correct symbol-root. */
2735 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2736 : derived
->f2k_derived
->tb_sym_root
);
2740 /* Try to find it in the current type's namespace. */
2741 res
= gfc_find_symtree (root
, name
);
2742 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2748 if (!noaccess
&& derived
->attr
.use_assoc
2749 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2752 gfc_error ("%qs of %qs is PRIVATE at %L",
2753 name
, derived
->name
, where
);
2761 /* Otherwise, recurse on parent type if derived is an extension. */
2762 if (derived
->attr
.extension
)
2764 gfc_symbol
* super_type
;
2765 super_type
= gfc_get_derived_super_type (derived
);
2766 gcc_assert (super_type
);
2768 return find_typebound_proc_uop (super_type
, t
, name
,
2769 noaccess
, uop
, where
);
2772 /* Nothing found. */
2777 /* Find a type-bound procedure or user operator by name for a derived-type
2778 (looking recursively through the super-types). */
2781 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2782 const char* name
, bool noaccess
, locus
* where
)
2784 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2788 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2789 const char* name
, bool noaccess
, locus
* where
)
2791 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2795 /* Find a type-bound intrinsic operator looking recursively through the
2796 super-type hierarchy. */
2799 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2800 gfc_intrinsic_op op
, bool noaccess
,
2803 gfc_typebound_proc
* res
;
2805 /* Set default to failure. */
2809 /* Try to find it in the current type's namespace. */
2810 if (derived
->f2k_derived
)
2811 res
= derived
->f2k_derived
->tb_op
[op
];
2816 if (res
&& !res
->error
)
2822 if (!noaccess
&& derived
->attr
.use_assoc
2823 && res
->access
== ACCESS_PRIVATE
)
2826 gfc_error ("%qs of %qs is PRIVATE at %L",
2827 gfc_op2string (op
), derived
->name
, where
);
2835 /* Otherwise, recurse on parent type if derived is an extension. */
2836 if (derived
->attr
.extension
)
2838 gfc_symbol
* super_type
;
2839 super_type
= gfc_get_derived_super_type (derived
);
2840 gcc_assert (super_type
);
2842 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2846 /* Nothing found. */
2851 /* Get a typebound-procedure symtree or create and insert it if not yet
2852 present. This is like a very simplified version of gfc_get_sym_tree for
2853 tbp-symtrees rather than regular ones. */
2856 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2858 gfc_symtree
*result
;
2860 result
= gfc_find_symtree (*root
, name
);
2863 result
= gfc_new_symtree (root
, name
);
2864 gcc_assert (result
);
2865 result
->n
.tb
= NULL
;