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)
238 /* Avoid losing memory. */
239 gfc_free_ref_list (*tail
);
240 (*tail
) = gfc_get_ref();
241 (*tail
)->next
= next
;
242 (*tail
)->type
= REF_COMPONENT
;
243 (*tail
)->u
.c
.sym
= derived
;
244 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
245 gcc_assert((*tail
)->u
.c
.component
);
247 e
->ts
= (*tail
)->u
.c
.component
->ts
;
251 /* This is used to add both the _data component reference and an array
252 reference to class expressions. Used in translation of intrinsic
253 array inquiry functions. */
256 gfc_add_class_array_ref (gfc_expr
*e
)
258 int rank
= CLASS_DATA (e
)->as
->rank
;
259 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
261 gfc_add_component_ref (e
, "_data");
263 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
266 if (ref
->type
!= REF_ARRAY
)
268 ref
->next
= gfc_get_ref ();
270 ref
->type
= REF_ARRAY
;
271 ref
->u
.ar
.type
= AR_FULL
;
277 /* Unfortunately, class array expressions can appear in various conditions;
278 with and without both _data component and an arrayspec. This function
279 deals with that variability. The previous reference to 'ref' is to a
283 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
285 bool no_data
= false;
286 bool with_data
= false;
288 /* An array reference with no _data component. */
289 if (ref
&& ref
->type
== REF_ARRAY
291 && ref
->u
.ar
.type
!= AR_ELEMENT
)
294 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
298 /* Cover cases where _data appears, with or without an array ref. */
299 if (ref
&& ref
->type
== REF_COMPONENT
300 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
308 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
310 && ref
->type
== REF_COMPONENT
311 && ref
->next
->type
== REF_ARRAY
312 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
316 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
320 return no_data
|| with_data
;
324 /* Returns true if the expression contains a reference to a class
325 array. Notice that class array elements return false. */
328 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
338 /* Is this a class array object? ie. Is the symbol of type class? */
340 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
341 && CLASS_DATA (e
->symtree
->n
.sym
)
342 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
343 && class_array_ref_detected (e
->ref
, full_array
))
346 /* Or is this a class array component reference? */
347 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
349 if (ref
->type
== REF_COMPONENT
350 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
351 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
352 && class_array_ref_detected (ref
->next
, full_array
))
360 /* Returns true if the expression is a reference to a class
361 scalar. This function is necessary because such expressions
362 can be dressed with a reference to the _data component and so
363 have a type other than BT_CLASS. */
366 gfc_is_class_scalar_expr (gfc_expr
*e
)
373 /* Is this a class object? */
375 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
376 && CLASS_DATA (e
->symtree
->n
.sym
)
377 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
379 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
380 && e
->ref
->next
== NULL
)))
383 /* Or is the final reference BT_CLASS or _data? */
384 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
386 if (ref
->type
== REF_COMPONENT
387 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
388 && CLASS_DATA (ref
->u
.c
.component
)
389 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
390 && (ref
->next
== NULL
391 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
392 && ref
->next
->next
== NULL
)))
400 /* Tells whether the expression E is a reference to a (scalar) class container.
401 Scalar because array class containers usually have an array reference after
402 them, and gfc_fix_class_refs will add the missing "_data" component reference
406 gfc_is_class_container_ref (gfc_expr
*e
)
411 if (e
->expr_type
!= EXPR_VARIABLE
)
412 return e
->ts
.type
== BT_CLASS
;
414 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
419 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
421 if (ref
->type
!= REF_COMPONENT
)
423 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
433 /* Build an initializer for CLASS pointers,
434 initializing the _data component to the init_expr (or NULL) and the _vptr
435 component to the corresponding type (or the declared type, given by ts). */
438 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
442 gfc_symbol
*vtab
= NULL
;
444 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
445 vtab
= gfc_find_vtab (&init_expr
->ts
);
447 vtab
= gfc_find_vtab (ts
);
449 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
450 &ts
->u
.derived
->declared_at
);
453 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
455 gfc_constructor
*ctor
= gfc_constructor_get();
456 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
457 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
458 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
459 ctor
->expr
= gfc_copy_expr (init_expr
);
461 ctor
->expr
= gfc_get_null_expr (NULL
);
462 gfc_constructor_append (&init
->value
.constructor
, ctor
);
469 /* Create a unique string identifier for a derived type, composed of its name
470 and module name. This is used to construct unique names for the class
471 containers and vtab symbols. */
474 get_unique_type_string (char *string
, gfc_symbol
*derived
)
476 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
477 if (derived
->attr
.unlimited_polymorphic
)
478 strcpy (dt_name
, "STAR");
480 strcpy (dt_name
, derived
->name
);
481 dt_name
[0] = TOUPPER (dt_name
[0]);
482 if (derived
->attr
.unlimited_polymorphic
)
483 sprintf (string
, "_%s", dt_name
);
484 else if (derived
->module
)
485 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
486 else if (derived
->ns
->proc_name
)
487 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
489 sprintf (string
, "_%s", dt_name
);
493 /* A relative of 'get_unique_type_string' which makes sure the generated
494 string will not be too long (replacing it by a hash string if needed). */
497 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
499 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
500 get_unique_type_string (&tmp
[0], derived
);
501 /* If string is too long, use hash value in hex representation (allow for
502 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
503 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
504 where %d is the (co)rank which can be up to n = 15. */
505 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
507 int h
= gfc_hash_value (derived
);
508 sprintf (string
, "%X", h
);
511 strcpy (string
, tmp
);
515 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
518 gfc_hash_value (gfc_symbol
*sym
)
520 unsigned int hash
= 0;
521 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
524 get_unique_type_string (&c
[0], sym
);
527 for (i
= 0; i
< len
; i
++)
528 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
530 /* Return the hash but take the modulus for the sake of module read,
531 even though this slightly increases the chance of collision. */
532 return (hash
% 100000000);
536 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
539 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
541 unsigned int hash
= 0;
542 const char *c
= gfc_typename (ts
);
547 for (i
= 0; i
< len
; i
++)
548 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
550 /* Return the hash but take the modulus for the sake of module read,
551 even though this slightly increases the chance of collision. */
552 return (hash
% 100000000);
556 /* Get the _len component from a class/derived object storing a string.
557 For unlimited polymorphic entities a ref to the _data component is available
558 while a ref to the _len component is needed. This routine traverese the
559 ref-chain and strips the last ref to a _data from it replacing it with a
560 ref to the _len component. */
563 gfc_get_len_component (gfc_expr
*e
)
566 gfc_ref
*ref
, **last
;
568 ptr
= gfc_copy_expr (e
);
570 /* We need to remove the last _data component ref from ptr. */
576 && ref
->type
== REF_COMPONENT
577 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
579 gfc_free_ref_list (ref
);
586 /* And replace if with a ref to the _len component. */
587 gfc_add_component_ref (ptr
, "_len");
592 /* Build a polymorphic CLASS entity, using the symbol that comes from
593 build_sym. A CLASS entity is represented by an encapsulating type,
594 which contains the declared type as '_data' component, plus a pointer
595 component '_vptr' which determines the dynamic type. When this CLASS
596 entity is unlimited polymorphic, then also add a component '_len' to
597 store the length of string when that is stored in it. */
600 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
603 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
612 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
614 gfc_error ("Assumed size polymorphic objects or components, such "
615 "as that at %C, have not yet been implemented");
620 /* Class container has already been built. */
623 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
624 || attr
->select_type_temporary
|| attr
->associate_var
;
627 /* We can not build the class container yet. */
630 /* Determine the name of the encapsulating type. */
631 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
632 get_unique_hashed_string (tname
, ts
->u
.derived
);
633 if ((*as
) && attr
->allocatable
)
634 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
635 else if ((*as
) && attr
->pointer
)
636 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
638 sprintf (name
, "__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
639 else if (attr
->pointer
)
640 sprintf (name
, "__class_%s_p", tname
);
641 else if (attr
->allocatable
)
642 sprintf (name
, "__class_%s_a", tname
);
644 sprintf (name
, "__class_%s_t", tname
);
646 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
648 /* Find the top-level namespace. */
649 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
654 ns
= ts
->u
.derived
->ns
;
656 gfc_find_symbol (name
, ns
, 0, &fclass
);
660 /* If not there, create a new symbol. */
661 fclass
= gfc_new_symbol (name
, ns
);
662 st
= gfc_new_symtree (&ns
->sym_root
, name
);
664 gfc_set_sym_referenced (fclass
);
666 fclass
->ts
.type
= BT_UNKNOWN
;
667 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
668 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
669 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
670 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
674 /* Add component '_data'. */
675 if (!gfc_add_component (fclass
, "_data", &c
))
678 c
->ts
.type
= BT_DERIVED
;
679 c
->attr
.access
= ACCESS_PRIVATE
;
680 c
->ts
.u
.derived
= ts
->u
.derived
;
681 c
->attr
.class_pointer
= attr
->pointer
;
682 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
683 || attr
->select_type_temporary
;
684 c
->attr
.allocatable
= attr
->allocatable
;
685 c
->attr
.dimension
= attr
->dimension
;
686 c
->attr
.codimension
= attr
->codimension
;
687 c
->attr
.abstract
= fclass
->attr
.abstract
;
689 c
->initializer
= NULL
;
691 /* Add component '_vptr'. */
692 if (!gfc_add_component (fclass
, "_vptr", &c
))
694 c
->ts
.type
= BT_DERIVED
;
695 c
->attr
.access
= ACCESS_PRIVATE
;
698 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
700 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
702 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
704 /* Add component '_len'. Only unlimited polymorphic pointers may
705 have a string assigned to them, i.e., only those need the _len
707 if (!gfc_add_component (fclass
, "_len", &c
))
709 c
->ts
.type
= BT_INTEGER
;
711 c
->attr
.access
= ACCESS_PRIVATE
;
712 c
->attr
.artificial
= 1;
715 /* Build vtab later. */
716 c
->ts
.u
.derived
= NULL
;
719 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
721 /* Since the extension field is 8 bit wide, we can only have
722 up to 255 extension levels. */
723 if (ts
->u
.derived
->attr
.extension
== 255)
725 gfc_error ("Maximum extension level reached with type %qs at %L",
726 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
730 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
731 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
732 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
735 fclass
->attr
.is_class
= 1;
736 ts
->u
.derived
= fclass
;
737 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
743 /* Add a procedure pointer component to the vtype
744 to represent a specific type-bound procedure. */
747 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
751 if (tb
->non_overridable
)
754 c
= gfc_find_component (vtype
, name
, true, true);
758 /* Add procedure component. */
759 if (!gfc_add_component (vtype
, name
, &c
))
763 c
->tb
= XCNEW (gfc_typebound_proc
);
766 c
->attr
.procedure
= 1;
767 c
->attr
.proc_pointer
= 1;
768 c
->attr
.flavor
= FL_PROCEDURE
;
769 c
->attr
.access
= ACCESS_PRIVATE
;
770 c
->attr
.external
= 1;
772 c
->attr
.if_source
= IFSRC_IFBODY
;
774 else if (c
->attr
.proc_pointer
&& c
->tb
)
782 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
783 c
->ts
.interface
= ifc
;
785 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
786 c
->attr
.pure
= ifc
->attr
.pure
;
791 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
794 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
800 add_procs_to_declared_vtab1 (st
->left
, vtype
);
803 add_procs_to_declared_vtab1 (st
->right
, vtype
);
805 if (st
->n
.tb
&& !st
->n
.tb
->error
806 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
807 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
811 /* Copy procedure pointers components from the parent type. */
814 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
819 vtab
= gfc_find_derived_vtab (declared
);
821 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
823 if (gfc_find_component (vtype
, cmp
->name
, true, true))
826 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
831 /* Returns true if any of its nonpointer nonallocatable components or
832 their nonpointer nonallocatable subcomponents has a finalization
836 has_finalizer_component (gfc_symbol
*derived
)
840 for (c
= derived
->components
; c
; c
= c
->next
)
842 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
843 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
846 if (c
->ts
.type
== BT_DERIVED
847 && !c
->attr
.pointer
&& !c
->attr
.allocatable
848 && has_finalizer_component (c
->ts
.u
.derived
))
856 comp_is_finalizable (gfc_component
*comp
)
858 if (comp
->attr
.proc_pointer
)
860 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
862 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
863 && (comp
->ts
.u
.derived
->attr
.alloc_comp
864 || has_finalizer_component (comp
->ts
.u
.derived
)
865 || (comp
->ts
.u
.derived
->f2k_derived
866 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
868 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
869 && CLASS_DATA (comp
)->attr
.allocatable
)
876 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
877 neither allocatable nor a pointer but has a finalizer, call it. If it
878 is a nonpointer component with allocatable components or has finalizers, walk
879 them. Either of them is required; other nonallocatables and pointers aren't
881 Note: If the component is allocatable, the DEALLOCATE handling takes care
882 of calling the appropriate finalizers, coarray deregistering, and
883 deallocation of allocatable subcomponents. */
886 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
887 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
888 gfc_namespace
*sub_ns
)
893 if (!comp_is_finalizable (comp
))
896 e
= gfc_copy_expr (expr
);
898 e
->ref
= ref
= gfc_get_ref ();
901 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
903 ref
->next
= gfc_get_ref ();
906 ref
->type
= REF_COMPONENT
;
907 ref
->u
.c
.sym
= derived
;
908 ref
->u
.c
.component
= comp
;
911 if (comp
->attr
.dimension
|| comp
->attr
.codimension
912 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
913 && (CLASS_DATA (comp
)->attr
.dimension
914 || CLASS_DATA (comp
)->attr
.codimension
)))
916 ref
->next
= gfc_get_ref ();
917 ref
->next
->type
= REF_ARRAY
;
918 ref
->next
->u
.ar
.dimen
= 0;
919 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
921 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
922 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
925 /* Call DEALLOCATE (comp, stat=ignore). */
926 if (comp
->attr
.allocatable
927 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
928 && CLASS_DATA (comp
)->attr
.allocatable
))
930 gfc_code
*dealloc
, *block
= NULL
;
932 /* Add IF (fini_coarray). */
933 if (comp
->attr
.codimension
934 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
935 && CLASS_DATA (comp
)->attr
.codimension
))
937 block
= gfc_get_code (EXEC_IF
);
940 (*code
)->next
= block
;
941 (*code
) = (*code
)->next
;
946 block
->block
= gfc_get_code (EXEC_IF
);
947 block
= block
->block
;
948 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
951 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
953 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
954 dealloc
->ext
.alloc
.list
->expr
= e
;
955 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
957 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
958 cond
->block
= gfc_get_code (EXEC_IF
);
959 cond
->block
->expr1
= gfc_get_expr ();
960 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
961 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
962 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
963 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
964 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
965 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
966 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
967 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
968 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
969 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
970 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
971 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
972 cond
->block
->next
= dealloc
;
978 (*code
)->next
= cond
;
979 (*code
) = (*code
)->next
;
984 else if (comp
->ts
.type
== BT_DERIVED
985 && comp
->ts
.u
.derived
->f2k_derived
986 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
988 /* Call FINAL_WRAPPER (comp); */
989 gfc_code
*final_wrap
;
993 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
994 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
995 if (strcmp (c
->name
, "_final") == 0)
999 final_wrap
= gfc_get_code (EXEC_CALL
);
1000 final_wrap
->symtree
= c
->initializer
->symtree
;
1001 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1002 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1003 final_wrap
->ext
.actual
->expr
= e
;
1007 (*code
)->next
= final_wrap
;
1008 (*code
) = (*code
)->next
;
1011 (*code
) = final_wrap
;
1017 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1018 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1025 /* Generate code equivalent to
1026 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1027 + offset, c_ptr), ptr). */
1030 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1031 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1034 gfc_expr
*expr
, *expr2
;
1036 /* C_F_POINTER(). */
1037 block
= gfc_get_code (EXEC_CALL
);
1038 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1039 block
->resolved_sym
= block
->symtree
->n
.sym
;
1040 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1041 block
->resolved_sym
->attr
.intrinsic
= 1;
1042 block
->resolved_sym
->attr
.subroutine
= 1;
1043 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1044 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1045 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1046 gfc_commit_symbol (block
->resolved_sym
);
1048 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1049 block
->ext
.actual
= gfc_get_actual_arglist ();
1050 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1051 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1053 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1055 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1057 /* TRANSFER's first argument: C_LOC (array). */
1058 expr
= gfc_get_expr ();
1059 expr
->expr_type
= EXPR_FUNCTION
;
1060 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1061 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1062 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1063 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1064 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1065 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1066 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1067 expr
->value
.function
.actual
->expr
1068 = gfc_lval_expr_from_sym (array
);
1069 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1070 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1071 expr
->ts
.type
= BT_INTEGER
;
1072 expr
->ts
.kind
= gfc_index_integer_kind
;
1075 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1076 gfc_current_locus
, 3, expr
,
1077 gfc_get_int_expr (gfc_index_integer_kind
,
1079 expr2
->ts
.type
= BT_INTEGER
;
1080 expr2
->ts
.kind
= gfc_index_integer_kind
;
1082 /* <array addr> + <offset>. */
1083 block
->ext
.actual
->expr
= gfc_get_expr ();
1084 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1085 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1086 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1087 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1088 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1090 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1091 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1092 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1093 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1099 /* Calculates the offset to the (idx+1)th element of an array, taking the
1100 stride into account. It generates the code:
1103 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1105 offset = offset * byte_stride. */
1108 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1109 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1110 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1111 gfc_code
*block
, gfc_namespace
*sub_ns
)
1114 gfc_expr
*expr
, *expr2
;
1117 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1118 block
= block
->next
;
1119 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1120 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1123 iter
= gfc_get_iterator ();
1124 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1125 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1126 iter
->end
= gfc_copy_expr (rank
);
1127 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1128 block
->next
= gfc_get_code (EXEC_DO
);
1129 block
= block
->next
;
1130 block
->ext
.iterator
= iter
;
1131 block
->block
= gfc_get_code (EXEC_DO
);
1133 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1136 /* mod (idx, sizes(idx2)). */
1137 expr
= gfc_lval_expr_from_sym (sizes
);
1138 expr
->ref
= gfc_get_ref ();
1139 expr
->ref
->type
= REF_ARRAY
;
1140 expr
->ref
->u
.ar
.as
= sizes
->as
;
1141 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1142 expr
->ref
->u
.ar
.dimen
= 1;
1143 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1144 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1146 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1147 gfc_current_locus
, 2,
1148 gfc_lval_expr_from_sym (idx
), expr
);
1151 /* (...) / sizes(idx2-1). */
1152 expr2
= gfc_get_expr ();
1153 expr2
->expr_type
= EXPR_OP
;
1154 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1155 expr2
->value
.op
.op1
= expr
;
1156 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1157 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1158 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1159 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1160 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1161 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1162 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1163 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1164 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1165 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1166 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1167 = gfc_lval_expr_from_sym (idx2
);
1168 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1169 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1170 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1171 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1172 expr2
->ts
= idx
->ts
;
1174 /* ... * strides(idx2). */
1175 expr
= gfc_get_expr ();
1176 expr
->expr_type
= EXPR_OP
;
1177 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1178 expr
->value
.op
.op1
= expr2
;
1179 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1180 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1181 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1182 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1183 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1184 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1185 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1186 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1189 /* offset = offset + ... */
1190 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1191 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1192 block
->block
->next
->expr2
= gfc_get_expr ();
1193 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1194 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1195 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1196 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1197 block
->block
->next
->expr2
->ts
= idx
->ts
;
1199 /* After the loop: offset = offset * byte_stride. */
1200 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1201 block
= block
->next
;
1202 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1203 block
->expr2
= gfc_get_expr ();
1204 block
->expr2
->expr_type
= EXPR_OP
;
1205 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1206 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1207 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1208 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1213 /* Insert code of the following form:
1216 integer(c_intptr_t) :: i
1218 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1219 && (is_contiguous || !final_rank3->attr.contiguous
1220 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1221 || 0 == STORAGE_SIZE (array)) then
1222 call final_rank3 (array)
1225 integer(c_intptr_t) :: offset, j
1226 type(t) :: tmp(shape (array))
1228 do i = 0, size (array)-1
1229 offset = obtain_offset(i, strides, sizes, byte_stride)
1230 addr = transfer (c_loc (array), addr) + offset
1231 call c_f_pointer (transfer (addr, cptr), ptr)
1233 addr = transfer (c_loc (tmp), addr)
1234 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1235 call c_f_pointer (transfer (addr, cptr), ptr2)
1238 call final_rank3 (tmp)
1244 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1245 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1246 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1248 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1249 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1250 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1251 gfc_namespace
*sub_ns
)
1253 gfc_symbol
*tmp_array
, *ptr2
;
1254 gfc_expr
*size_expr
, *offset2
, *expr
;
1260 block
->next
= gfc_get_code (EXEC_IF
);
1261 block
= block
->next
;
1263 block
->block
= gfc_get_code (EXEC_IF
);
1264 block
= block
->block
;
1266 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1267 size_expr
= gfc_get_expr ();
1268 size_expr
->where
= gfc_current_locus
;
1269 size_expr
->expr_type
= EXPR_OP
;
1270 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1272 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1273 size_expr
->value
.op
.op1
1274 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1275 "storage_size", gfc_current_locus
, 2,
1276 gfc_lval_expr_from_sym (array
),
1277 gfc_get_int_expr (gfc_index_integer_kind
,
1280 /* NUMERIC_STORAGE_SIZE. */
1281 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1282 gfc_character_storage_size
);
1283 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1284 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1286 /* IF condition: (stride == size_expr
1287 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1289 || 0 == size_expr. */
1290 block
->expr1
= gfc_get_expr ();
1291 block
->expr1
->ts
.type
= BT_LOGICAL
;
1292 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1293 block
->expr1
->expr_type
= EXPR_OP
;
1294 block
->expr1
->where
= gfc_current_locus
;
1296 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1298 /* byte_stride == size_expr */
1299 expr
= gfc_get_expr ();
1300 expr
->ts
.type
= BT_LOGICAL
;
1301 expr
->ts
.kind
= gfc_default_logical_kind
;
1302 expr
->expr_type
= EXPR_OP
;
1303 expr
->where
= gfc_current_locus
;
1304 expr
->value
.op
.op
= INTRINSIC_EQ
;
1306 = gfc_lval_expr_from_sym (byte_stride
);
1307 expr
->value
.op
.op2
= size_expr
;
1309 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1310 add is_contiguous check. */
1312 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1313 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1316 expr2
= gfc_get_expr ();
1317 expr2
->ts
.type
= BT_LOGICAL
;
1318 expr2
->ts
.kind
= gfc_default_logical_kind
;
1319 expr2
->expr_type
= EXPR_OP
;
1320 expr2
->where
= gfc_current_locus
;
1321 expr2
->value
.op
.op
= INTRINSIC_AND
;
1322 expr2
->value
.op
.op1
= expr
;
1323 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1327 block
->expr1
->value
.op
.op1
= expr
;
1329 /* 0 == size_expr */
1330 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1331 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1332 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1333 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1334 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1335 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1336 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1337 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1338 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1340 /* IF body: call final subroutine. */
1341 block
->next
= gfc_get_code (EXEC_CALL
);
1342 block
->next
->symtree
= fini
->proc_tree
;
1343 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1344 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1345 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1349 block
->block
= gfc_get_code (EXEC_IF
);
1350 block
= block
->block
;
1352 /* BLOCK ... END BLOCK. */
1353 block
->next
= gfc_get_code (EXEC_BLOCK
);
1354 block
= block
->next
;
1356 ns
= gfc_build_block_ns (sub_ns
);
1357 block
->ext
.block
.ns
= ns
;
1358 block
->ext
.block
.assoc
= NULL
;
1360 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1361 ptr2
->ts
.type
= BT_DERIVED
;
1362 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1363 ptr2
->attr
.flavor
= FL_VARIABLE
;
1364 ptr2
->attr
.pointer
= 1;
1365 ptr2
->attr
.artificial
= 1;
1366 gfc_set_sym_referenced (ptr2
);
1367 gfc_commit_symbol (ptr2
);
1369 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1370 tmp_array
->ts
.type
= BT_DERIVED
;
1371 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1372 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1373 tmp_array
->attr
.dimension
= 1;
1374 tmp_array
->attr
.artificial
= 1;
1375 tmp_array
->as
= gfc_get_array_spec();
1376 tmp_array
->attr
.intent
= INTENT_INOUT
;
1377 tmp_array
->as
->type
= AS_EXPLICIT
;
1378 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1380 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1382 gfc_expr
*shape_expr
;
1383 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1385 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1387 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1388 gfc_current_locus
, 3,
1389 gfc_lval_expr_from_sym (array
),
1390 gfc_get_int_expr (gfc_default_integer_kind
,
1392 gfc_get_int_expr (gfc_default_integer_kind
,
1394 gfc_index_integer_kind
));
1395 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1396 tmp_array
->as
->upper
[i
] = shape_expr
;
1398 gfc_set_sym_referenced (tmp_array
);
1399 gfc_commit_symbol (tmp_array
);
1402 iter
= gfc_get_iterator ();
1403 iter
->var
= gfc_lval_expr_from_sym (idx
);
1404 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1405 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1406 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1408 block
= gfc_get_code (EXEC_DO
);
1410 block
->ext
.iterator
= iter
;
1411 block
->block
= gfc_get_code (EXEC_DO
);
1413 /* Offset calculation for the new array: idx * size of type (in bytes). */
1414 offset2
= gfc_get_expr ();
1415 offset2
->expr_type
= EXPR_OP
;
1416 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1417 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1418 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1419 offset2
->ts
= byte_stride
->ts
;
1421 /* Offset calculation of "array". */
1422 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1423 byte_stride
, rank
, block
->block
, sub_ns
);
1426 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1427 + idx * stride, c_ptr), ptr). */
1428 block2
->next
= finalization_scalarizer (array
, ptr
,
1429 gfc_lval_expr_from_sym (offset
),
1431 block2
= block2
->next
;
1432 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1433 block2
= block2
->next
;
1436 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1437 block2
= block2
->next
;
1438 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1439 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1441 /* Call now the user's final subroutine. */
1442 block
->next
= gfc_get_code (EXEC_CALL
);
1443 block
= block
->next
;
1444 block
->symtree
= fini
->proc_tree
;
1445 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1446 block
->ext
.actual
= gfc_get_actual_arglist ();
1447 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1449 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1455 iter
= gfc_get_iterator ();
1456 iter
->var
= gfc_lval_expr_from_sym (idx
);
1457 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1458 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1459 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1461 block
->next
= gfc_get_code (EXEC_DO
);
1462 block
= block
->next
;
1463 block
->ext
.iterator
= iter
;
1464 block
->block
= gfc_get_code (EXEC_DO
);
1466 /* Offset calculation of "array". */
1467 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1468 byte_stride
, rank
, block
->block
, sub_ns
);
1471 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1472 + offset, c_ptr), ptr). */
1473 block2
->next
= finalization_scalarizer (array
, ptr
,
1474 gfc_lval_expr_from_sym (offset
),
1476 block2
= block2
->next
;
1477 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1478 gfc_copy_expr (offset2
), sub_ns
);
1479 block2
= block2
->next
;
1482 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1483 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1484 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1488 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1489 derived type "derived". The function first calls the approriate FINAL
1490 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1491 components (but not the inherited ones). Last, it calls the wrapper
1492 subroutine of the parent. The generated wrapper procedure takes as argument
1493 an assumed-rank array.
1494 If neither allocatable components nor FINAL subroutines exists, the vtab
1495 will contain a NULL pointer.
1496 The generated function has the form
1497 _final(assumed-rank array, stride, skip_corarray)
1498 where the array has to be contiguous (except of the lowest dimension). The
1499 stride (in bytes) is used to allow different sizes for ancestor types by
1500 skipping over the additionally added components in the scalarizer. If
1501 "fini_coarray" is false, coarray components are not finalized to allow for
1502 the correct semantic with intrinsic assignment. */
1505 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1506 const char *tname
, gfc_component
*vtab_final
)
1508 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1509 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1510 gfc_component
*comp
;
1511 gfc_namespace
*sub_ns
;
1512 gfc_code
*last_code
, *block
;
1513 char name
[GFC_MAX_SYMBOL_LEN
+1];
1514 bool finalizable_comp
= false;
1515 bool expr_null_wrapper
= false;
1516 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1519 if (derived
->attr
.unlimited_polymorphic
)
1521 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1525 /* Search for the ancestor's finalizers. */
1526 if (derived
->attr
.extension
&& derived
->components
1527 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1528 || has_finalizer_component (derived
)))
1531 gfc_component
*comp
;
1533 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1534 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1535 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1537 ancestor_wrapper
= comp
->initializer
;
1542 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1543 components: Return a NULL() expression; we defer this a bit to have have
1544 an interface declaration. */
1545 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1546 && !derived
->attr
.alloc_comp
1547 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1548 && !has_finalizer_component (derived
))
1549 expr_null_wrapper
= true;
1551 /* Check whether there are new allocatable components. */
1552 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1554 if (comp
== derived
->components
&& derived
->attr
.extension
1555 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1558 finalizable_comp
|= comp_is_finalizable (comp
);
1561 /* If there is no new finalizer and no new allocatable, return with
1562 an expr to the ancestor's one. */
1563 if (!expr_null_wrapper
&& !finalizable_comp
1564 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1566 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1567 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1568 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1569 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1573 /* We now create a wrapper, which does the following:
1574 1. Call the suitable finalization subroutine for this type
1575 2. Loop over all noninherited allocatable components and noninherited
1576 components with allocatable components and DEALLOCATE those; this will
1577 take care of finalizers, coarray deregistering and allocatable
1579 3. Call the ancestor's finalizer. */
1581 /* Declare the wrapper function; it takes an assumed-rank array
1582 and a VALUE logical as arguments. */
1584 /* Set up the namespace. */
1585 sub_ns
= gfc_get_namespace (ns
, 0);
1586 sub_ns
->sibling
= ns
->contained
;
1587 if (!expr_null_wrapper
)
1588 ns
->contained
= sub_ns
;
1589 sub_ns
->resolved
= 1;
1591 /* Set up the procedure symbol. */
1592 sprintf (name
, "__final_%s", tname
);
1593 gfc_get_symbol (name
, sub_ns
, &final
);
1594 sub_ns
->proc_name
= final
;
1595 final
->attr
.flavor
= FL_PROCEDURE
;
1596 final
->attr
.function
= 1;
1597 final
->attr
.pure
= 0;
1598 final
->result
= final
;
1599 final
->ts
.type
= BT_INTEGER
;
1601 final
->attr
.artificial
= 1;
1602 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1603 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1604 final
->module
= ns
->proc_name
->name
;
1605 gfc_set_sym_referenced (final
);
1606 gfc_commit_symbol (final
);
1608 /* Set up formal argument. */
1609 gfc_get_symbol ("array", sub_ns
, &array
);
1610 array
->ts
.type
= BT_DERIVED
;
1611 array
->ts
.u
.derived
= derived
;
1612 array
->attr
.flavor
= FL_VARIABLE
;
1613 array
->attr
.dummy
= 1;
1614 array
->attr
.contiguous
= 1;
1615 array
->attr
.dimension
= 1;
1616 array
->attr
.artificial
= 1;
1617 array
->as
= gfc_get_array_spec();
1618 array
->as
->type
= AS_ASSUMED_RANK
;
1619 array
->as
->rank
= -1;
1620 array
->attr
.intent
= INTENT_INOUT
;
1621 gfc_set_sym_referenced (array
);
1622 final
->formal
= gfc_get_formal_arglist ();
1623 final
->formal
->sym
= array
;
1624 gfc_commit_symbol (array
);
1626 /* Set up formal argument. */
1627 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1628 byte_stride
->ts
.type
= BT_INTEGER
;
1629 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1630 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1631 byte_stride
->attr
.dummy
= 1;
1632 byte_stride
->attr
.value
= 1;
1633 byte_stride
->attr
.artificial
= 1;
1634 gfc_set_sym_referenced (byte_stride
);
1635 final
->formal
->next
= gfc_get_formal_arglist ();
1636 final
->formal
->next
->sym
= byte_stride
;
1637 gfc_commit_symbol (byte_stride
);
1639 /* Set up formal argument. */
1640 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1641 fini_coarray
->ts
.type
= BT_LOGICAL
;
1642 fini_coarray
->ts
.kind
= 1;
1643 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1644 fini_coarray
->attr
.dummy
= 1;
1645 fini_coarray
->attr
.value
= 1;
1646 fini_coarray
->attr
.artificial
= 1;
1647 gfc_set_sym_referenced (fini_coarray
);
1648 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1649 final
->formal
->next
->next
->sym
= fini_coarray
;
1650 gfc_commit_symbol (fini_coarray
);
1652 /* Return with a NULL() expression but with an interface which has
1653 the formal arguments. */
1654 if (expr_null_wrapper
)
1656 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1657 vtab_final
->ts
.interface
= final
;
1661 /* Local variables. */
1663 gfc_get_symbol ("idx", sub_ns
, &idx
);
1664 idx
->ts
.type
= BT_INTEGER
;
1665 idx
->ts
.kind
= gfc_index_integer_kind
;
1666 idx
->attr
.flavor
= FL_VARIABLE
;
1667 idx
->attr
.artificial
= 1;
1668 gfc_set_sym_referenced (idx
);
1669 gfc_commit_symbol (idx
);
1671 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1672 idx2
->ts
.type
= BT_INTEGER
;
1673 idx2
->ts
.kind
= gfc_index_integer_kind
;
1674 idx2
->attr
.flavor
= FL_VARIABLE
;
1675 idx2
->attr
.artificial
= 1;
1676 gfc_set_sym_referenced (idx2
);
1677 gfc_commit_symbol (idx2
);
1679 gfc_get_symbol ("offset", sub_ns
, &offset
);
1680 offset
->ts
.type
= BT_INTEGER
;
1681 offset
->ts
.kind
= gfc_index_integer_kind
;
1682 offset
->attr
.flavor
= FL_VARIABLE
;
1683 offset
->attr
.artificial
= 1;
1684 gfc_set_sym_referenced (offset
);
1685 gfc_commit_symbol (offset
);
1687 /* Create RANK expression. */
1688 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1689 gfc_current_locus
, 1,
1690 gfc_lval_expr_from_sym (array
));
1691 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1692 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1694 /* Create is_contiguous variable. */
1695 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1696 is_contiguous
->ts
.type
= BT_LOGICAL
;
1697 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1698 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1699 is_contiguous
->attr
.artificial
= 1;
1700 gfc_set_sym_referenced (is_contiguous
);
1701 gfc_commit_symbol (is_contiguous
);
1703 /* Create "sizes(0..rank)" variable, which contains the multiplied
1704 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1705 sizes(2) = sizes(1) * extent(dim=2) etc. */
1706 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1707 sizes
->ts
.type
= BT_INTEGER
;
1708 sizes
->ts
.kind
= gfc_index_integer_kind
;
1709 sizes
->attr
.flavor
= FL_VARIABLE
;
1710 sizes
->attr
.dimension
= 1;
1711 sizes
->attr
.artificial
= 1;
1712 sizes
->as
= gfc_get_array_spec();
1713 sizes
->attr
.intent
= INTENT_INOUT
;
1714 sizes
->as
->type
= AS_EXPLICIT
;
1715 sizes
->as
->rank
= 1;
1716 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1717 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1718 gfc_set_sym_referenced (sizes
);
1719 gfc_commit_symbol (sizes
);
1721 /* Create "strides(1..rank)" variable, which contains the strides per
1723 gfc_get_symbol ("strides", sub_ns
, &strides
);
1724 strides
->ts
.type
= BT_INTEGER
;
1725 strides
->ts
.kind
= gfc_index_integer_kind
;
1726 strides
->attr
.flavor
= FL_VARIABLE
;
1727 strides
->attr
.dimension
= 1;
1728 strides
->attr
.artificial
= 1;
1729 strides
->as
= gfc_get_array_spec();
1730 strides
->attr
.intent
= INTENT_INOUT
;
1731 strides
->as
->type
= AS_EXPLICIT
;
1732 strides
->as
->rank
= 1;
1733 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1734 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1735 gfc_set_sym_referenced (strides
);
1736 gfc_commit_symbol (strides
);
1739 /* Set return value to 0. */
1740 last_code
= gfc_get_code (EXEC_ASSIGN
);
1741 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1742 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1743 sub_ns
->code
= last_code
;
1745 /* Set: is_contiguous = .true. */
1746 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1747 last_code
= last_code
->next
;
1748 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1749 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1750 &gfc_current_locus
, true);
1752 /* Set: sizes(0) = 1. */
1753 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1754 last_code
= last_code
->next
;
1755 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1756 last_code
->expr1
->ref
= gfc_get_ref ();
1757 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1758 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1759 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1760 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1761 last_code
->expr1
->ref
->u
.ar
.start
[0]
1762 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1763 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1764 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1768 strides(idx) = _F._stride (array, dim=idx)
1769 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1770 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1774 iter
= gfc_get_iterator ();
1775 iter
->var
= gfc_lval_expr_from_sym (idx
);
1776 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1777 iter
->end
= gfc_copy_expr (rank
);
1778 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1779 last_code
->next
= gfc_get_code (EXEC_DO
);
1780 last_code
= last_code
->next
;
1781 last_code
->ext
.iterator
= iter
;
1782 last_code
->block
= gfc_get_code (EXEC_DO
);
1784 /* strides(idx) = _F._stride(array,dim=idx). */
1785 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1786 block
= last_code
->block
->next
;
1788 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1789 block
->expr1
->ref
= gfc_get_ref ();
1790 block
->expr1
->ref
->type
= REF_ARRAY
;
1791 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1792 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1793 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1794 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1795 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1797 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1798 gfc_current_locus
, 2,
1799 gfc_lval_expr_from_sym (array
),
1800 gfc_lval_expr_from_sym (idx
));
1802 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1803 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1804 block
= block
->next
;
1806 /* sizes(idx) = ... */
1807 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1808 block
->expr1
->ref
= gfc_get_ref ();
1809 block
->expr1
->ref
->type
= REF_ARRAY
;
1810 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1811 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1812 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1813 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1814 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1816 block
->expr2
= gfc_get_expr ();
1817 block
->expr2
->expr_type
= EXPR_OP
;
1818 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1821 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1822 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1823 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1824 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1825 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1826 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1827 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1828 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1829 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1830 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1831 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1832 = gfc_lval_expr_from_sym (idx
);
1833 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1834 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1835 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1836 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1838 /* size(array, dim=idx, kind=index_kind). */
1839 block
->expr2
->value
.op
.op2
1840 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1841 gfc_current_locus
, 3,
1842 gfc_lval_expr_from_sym (array
),
1843 gfc_lval_expr_from_sym (idx
),
1844 gfc_get_int_expr (gfc_index_integer_kind
,
1846 gfc_index_integer_kind
));
1847 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1848 block
->expr2
->ts
= idx
->ts
;
1850 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1851 block
->next
= gfc_get_code (EXEC_IF
);
1852 block
= block
->next
;
1854 block
->block
= gfc_get_code (EXEC_IF
);
1855 block
= block
->block
;
1857 /* if condition: strides(idx) /= sizes(idx-1). */
1858 block
->expr1
= gfc_get_expr ();
1859 block
->expr1
->ts
.type
= BT_LOGICAL
;
1860 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1861 block
->expr1
->expr_type
= EXPR_OP
;
1862 block
->expr1
->where
= gfc_current_locus
;
1863 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1865 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1866 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1867 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1868 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1869 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1870 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1871 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1872 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1874 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1875 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1876 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1877 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1878 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1879 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1880 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1881 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1882 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1883 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1884 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1885 = gfc_lval_expr_from_sym (idx
);
1886 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1887 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1888 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1889 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1891 /* if body: is_contiguous = .false. */
1892 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1893 block
= block
->next
;
1894 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1895 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1896 &gfc_current_locus
, false);
1898 /* Obtain the size (number of elements) of "array" MINUS ONE,
1899 which is used in the scalarization. */
1900 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1901 nelem
->ts
.type
= BT_INTEGER
;
1902 nelem
->ts
.kind
= gfc_index_integer_kind
;
1903 nelem
->attr
.flavor
= FL_VARIABLE
;
1904 nelem
->attr
.artificial
= 1;
1905 gfc_set_sym_referenced (nelem
);
1906 gfc_commit_symbol (nelem
);
1908 /* nelem = sizes (rank) - 1. */
1909 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1910 last_code
= last_code
->next
;
1912 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1914 last_code
->expr2
= gfc_get_expr ();
1915 last_code
->expr2
->expr_type
= EXPR_OP
;
1916 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1917 last_code
->expr2
->value
.op
.op2
1918 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1919 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1921 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1922 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1923 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1924 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1925 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1926 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1927 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1928 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1930 /* Call final subroutines. We now generate code like:
1932 integer, pointer :: ptr
1934 integer(c_intptr_t) :: i, addr
1936 select case (rank (array))
1938 ! If needed, the array is packed
1939 call final_rank3 (array)
1941 do i = 0, size (array)-1
1942 addr = transfer (c_loc (array), addr) + i * stride
1943 call c_f_pointer (transfer (addr, cptr), ptr)
1944 call elemental_final (ptr)
1948 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1950 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1952 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1953 ptr
->ts
.type
= BT_DERIVED
;
1954 ptr
->ts
.u
.derived
= derived
;
1955 ptr
->attr
.flavor
= FL_VARIABLE
;
1956 ptr
->attr
.pointer
= 1;
1957 ptr
->attr
.artificial
= 1;
1958 gfc_set_sym_referenced (ptr
);
1959 gfc_commit_symbol (ptr
);
1961 /* SELECT CASE (RANK (array)). */
1962 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1963 last_code
= last_code
->next
;
1964 last_code
->expr1
= gfc_copy_expr (rank
);
1967 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1969 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1970 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1976 /* CASE (fini_rank). */
1979 block
->block
= gfc_get_code (EXEC_SELECT
);
1980 block
= block
->block
;
1984 block
= gfc_get_code (EXEC_SELECT
);
1985 last_code
->block
= block
;
1987 block
->ext
.block
.case_list
= gfc_get_case ();
1988 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1989 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1990 block
->ext
.block
.case_list
->low
1991 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1992 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1994 block
->ext
.block
.case_list
->low
1995 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1996 block
->ext
.block
.case_list
->high
1997 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
1999 /* CALL fini_rank (array) - possibly with packing. */
2000 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2001 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2002 idx
, ptr
, nelem
, strides
,
2003 sizes
, idx2
, offset
, is_contiguous
,
2007 block
->next
= gfc_get_code (EXEC_CALL
);
2008 block
->next
->symtree
= fini
->proc_tree
;
2009 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2010 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2011 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2015 /* Elemental call - scalarized. */
2021 block
->block
= gfc_get_code (EXEC_SELECT
);
2022 block
= block
->block
;
2026 block
= gfc_get_code (EXEC_SELECT
);
2027 last_code
->block
= block
;
2029 block
->ext
.block
.case_list
= gfc_get_case ();
2032 iter
= gfc_get_iterator ();
2033 iter
->var
= gfc_lval_expr_from_sym (idx
);
2034 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2035 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2036 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2037 block
->next
= gfc_get_code (EXEC_DO
);
2038 block
= block
->next
;
2039 block
->ext
.iterator
= iter
;
2040 block
->block
= gfc_get_code (EXEC_DO
);
2042 /* Offset calculation. */
2043 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2044 byte_stride
, rank
, block
->block
,
2048 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2049 + offset, c_ptr), ptr). */
2051 = finalization_scalarizer (array
, ptr
,
2052 gfc_lval_expr_from_sym (offset
),
2054 block
= block
->next
;
2056 /* CALL final_elemental (array). */
2057 block
->next
= gfc_get_code (EXEC_CALL
);
2058 block
= block
->next
;
2059 block
->symtree
= fini_elem
->proc_tree
;
2060 block
->resolved_sym
= fini_elem
->proc_sym
;
2061 block
->ext
.actual
= gfc_get_actual_arglist ();
2062 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2066 /* Finalize and deallocate allocatable components. The same manual
2067 scalarization is used as above. */
2069 if (finalizable_comp
)
2072 gfc_code
*block
= NULL
;
2076 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2077 ptr
->ts
.type
= BT_DERIVED
;
2078 ptr
->ts
.u
.derived
= derived
;
2079 ptr
->attr
.flavor
= FL_VARIABLE
;
2080 ptr
->attr
.pointer
= 1;
2081 ptr
->attr
.artificial
= 1;
2082 gfc_set_sym_referenced (ptr
);
2083 gfc_commit_symbol (ptr
);
2086 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2087 stat
->attr
.flavor
= FL_VARIABLE
;
2088 stat
->attr
.artificial
= 1;
2089 stat
->ts
.type
= BT_INTEGER
;
2090 stat
->ts
.kind
= gfc_default_integer_kind
;
2091 gfc_set_sym_referenced (stat
);
2092 gfc_commit_symbol (stat
);
2095 iter
= gfc_get_iterator ();
2096 iter
->var
= gfc_lval_expr_from_sym (idx
);
2097 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2098 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2099 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2100 last_code
->next
= gfc_get_code (EXEC_DO
);
2101 last_code
= last_code
->next
;
2102 last_code
->ext
.iterator
= iter
;
2103 last_code
->block
= gfc_get_code (EXEC_DO
);
2105 /* Offset calculation. */
2106 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2107 byte_stride
, rank
, last_code
->block
,
2111 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2112 + idx * stride, c_ptr), ptr). */
2113 block
->next
= finalization_scalarizer (array
, ptr
,
2114 gfc_lval_expr_from_sym(offset
),
2116 block
= block
->next
;
2118 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2120 if (comp
== derived
->components
&& derived
->attr
.extension
2121 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2124 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2125 stat
, fini_coarray
, &block
, sub_ns
);
2126 if (!last_code
->block
->next
)
2127 last_code
->block
->next
= block
;
2132 /* Call the finalizer of the ancestor. */
2133 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2135 last_code
->next
= gfc_get_code (EXEC_CALL
);
2136 last_code
= last_code
->next
;
2137 last_code
->symtree
= ancestor_wrapper
->symtree
;
2138 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2140 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2141 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2142 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2143 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2144 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2145 last_code
->ext
.actual
->next
->next
->expr
2146 = gfc_lval_expr_from_sym (fini_coarray
);
2149 gfc_free_expr (rank
);
2150 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2151 vtab_final
->ts
.interface
= final
;
2155 /* Add procedure pointers for all type-bound procedures to a vtab. */
2158 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2160 gfc_symbol
* super_type
;
2162 super_type
= gfc_get_derived_super_type (derived
);
2164 if (super_type
&& (super_type
!= derived
))
2166 /* Make sure that the PPCs appear in the same order as in the parent. */
2167 copy_vtab_proc_comps (super_type
, vtype
);
2168 /* Only needed to get the PPC initializers right. */
2169 add_procs_to_declared_vtab (super_type
, vtype
);
2172 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2173 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2175 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2176 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2180 /* Find or generate the symbol for a derived type's vtab. */
2183 gfc_find_derived_vtab (gfc_symbol
*derived
)
2186 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2187 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2189 /* Find the top-level namespace. */
2190 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2194 /* If the type is a class container, use the underlying derived type. */
2195 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2196 derived
= gfc_get_derived_super_type (derived
);
2200 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2202 get_unique_hashed_string (tname
, derived
);
2203 sprintf (name
, "__vtab_%s", tname
);
2205 /* Look for the vtab symbol in various namespaces. */
2206 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2208 gfc_find_symbol (name
, ns
, 0, &vtab
);
2210 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2214 gfc_get_symbol (name
, ns
, &vtab
);
2215 vtab
->ts
.type
= BT_DERIVED
;
2216 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2217 &gfc_current_locus
))
2219 vtab
->attr
.target
= 1;
2220 vtab
->attr
.save
= SAVE_IMPLICIT
;
2221 vtab
->attr
.vtab
= 1;
2222 vtab
->attr
.access
= ACCESS_PUBLIC
;
2223 gfc_set_sym_referenced (vtab
);
2224 sprintf (name
, "__vtype_%s", tname
);
2226 gfc_find_symbol (name
, ns
, 0, &vtype
);
2230 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2232 gfc_get_symbol (name
, ns
, &vtype
);
2233 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2234 &gfc_current_locus
))
2236 vtype
->attr
.access
= ACCESS_PUBLIC
;
2237 vtype
->attr
.vtype
= 1;
2238 gfc_set_sym_referenced (vtype
);
2240 /* Add component '_hash'. */
2241 if (!gfc_add_component (vtype
, "_hash", &c
))
2243 c
->ts
.type
= BT_INTEGER
;
2245 c
->attr
.access
= ACCESS_PRIVATE
;
2246 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2247 NULL
, derived
->hash_value
);
2249 /* Add component '_size'. */
2250 if (!gfc_add_component (vtype
, "_size", &c
))
2252 c
->ts
.type
= BT_INTEGER
;
2254 c
->attr
.access
= ACCESS_PRIVATE
;
2255 /* Remember the derived type in ts.u.derived,
2256 so that the correct initializer can be set later on
2257 (in gfc_conv_structure). */
2258 c
->ts
.u
.derived
= derived
;
2259 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2262 /* Add component _extends. */
2263 if (!gfc_add_component (vtype
, "_extends", &c
))
2265 c
->attr
.pointer
= 1;
2266 c
->attr
.access
= ACCESS_PRIVATE
;
2267 if (!derived
->attr
.unlimited_polymorphic
)
2268 parent
= gfc_get_derived_super_type (derived
);
2274 parent_vtab
= gfc_find_derived_vtab (parent
);
2275 c
->ts
.type
= BT_DERIVED
;
2276 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2277 c
->initializer
= gfc_get_expr ();
2278 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2279 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2280 0, &c
->initializer
->symtree
);
2284 c
->ts
.type
= BT_DERIVED
;
2285 c
->ts
.u
.derived
= vtype
;
2286 c
->initializer
= gfc_get_null_expr (NULL
);
2289 if (!derived
->attr
.unlimited_polymorphic
2290 && derived
->components
== NULL
2291 && !derived
->attr
.zero_comp
)
2293 /* At this point an error must have occurred.
2294 Prevent further errors on the vtype components. */
2299 /* Add component _def_init. */
2300 if (!gfc_add_component (vtype
, "_def_init", &c
))
2302 c
->attr
.pointer
= 1;
2303 c
->attr
.artificial
= 1;
2304 c
->attr
.access
= ACCESS_PRIVATE
;
2305 c
->ts
.type
= BT_DERIVED
;
2306 c
->ts
.u
.derived
= derived
;
2307 if (derived
->attr
.unlimited_polymorphic
2308 || derived
->attr
.abstract
)
2309 c
->initializer
= gfc_get_null_expr (NULL
);
2312 /* Construct default initialization variable. */
2313 sprintf (name
, "__def_init_%s", tname
);
2314 gfc_get_symbol (name
, ns
, &def_init
);
2315 def_init
->attr
.target
= 1;
2316 def_init
->attr
.artificial
= 1;
2317 def_init
->attr
.save
= SAVE_IMPLICIT
;
2318 def_init
->attr
.access
= ACCESS_PUBLIC
;
2319 def_init
->attr
.flavor
= FL_VARIABLE
;
2320 gfc_set_sym_referenced (def_init
);
2321 def_init
->ts
.type
= BT_DERIVED
;
2322 def_init
->ts
.u
.derived
= derived
;
2323 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2325 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2328 /* Add component _copy. */
2329 if (!gfc_add_component (vtype
, "_copy", &c
))
2331 c
->attr
.proc_pointer
= 1;
2332 c
->attr
.access
= ACCESS_PRIVATE
;
2333 c
->tb
= XCNEW (gfc_typebound_proc
);
2335 if (derived
->attr
.unlimited_polymorphic
2336 || derived
->attr
.abstract
)
2337 c
->initializer
= gfc_get_null_expr (NULL
);
2340 /* Set up namespace. */
2341 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2342 sub_ns
->sibling
= ns
->contained
;
2343 ns
->contained
= sub_ns
;
2344 sub_ns
->resolved
= 1;
2345 /* Set up procedure symbol. */
2346 sprintf (name
, "__copy_%s", tname
);
2347 gfc_get_symbol (name
, sub_ns
, ©
);
2348 sub_ns
->proc_name
= copy
;
2349 copy
->attr
.flavor
= FL_PROCEDURE
;
2350 copy
->attr
.subroutine
= 1;
2351 copy
->attr
.pure
= 1;
2352 copy
->attr
.artificial
= 1;
2353 copy
->attr
.if_source
= IFSRC_DECL
;
2354 /* This is elemental so that arrays are automatically
2355 treated correctly by the scalarizer. */
2356 copy
->attr
.elemental
= 1;
2357 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2358 copy
->module
= ns
->proc_name
->name
;
2359 gfc_set_sym_referenced (copy
);
2360 /* Set up formal arguments. */
2361 gfc_get_symbol ("src", sub_ns
, &src
);
2362 src
->ts
.type
= BT_DERIVED
;
2363 src
->ts
.u
.derived
= derived
;
2364 src
->attr
.flavor
= FL_VARIABLE
;
2365 src
->attr
.dummy
= 1;
2366 src
->attr
.artificial
= 1;
2367 src
->attr
.intent
= INTENT_IN
;
2368 gfc_set_sym_referenced (src
);
2369 copy
->formal
= gfc_get_formal_arglist ();
2370 copy
->formal
->sym
= src
;
2371 gfc_get_symbol ("dst", sub_ns
, &dst
);
2372 dst
->ts
.type
= BT_DERIVED
;
2373 dst
->ts
.u
.derived
= derived
;
2374 dst
->attr
.flavor
= FL_VARIABLE
;
2375 dst
->attr
.dummy
= 1;
2376 dst
->attr
.artificial
= 1;
2377 dst
->attr
.intent
= INTENT_INOUT
;
2378 gfc_set_sym_referenced (dst
);
2379 copy
->formal
->next
= gfc_get_formal_arglist ();
2380 copy
->formal
->next
->sym
= dst
;
2382 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2383 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2384 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2385 /* Set initializer. */
2386 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2387 c
->ts
.interface
= copy
;
2390 /* Add component _final, which contains a procedure pointer to
2391 a wrapper which handles both the freeing of allocatable
2392 components and the calls to finalization subroutines.
2393 Note: The actual wrapper function can only be generated
2394 at resolution time. */
2395 if (!gfc_add_component (vtype
, "_final", &c
))
2397 c
->attr
.proc_pointer
= 1;
2398 c
->attr
.access
= ACCESS_PRIVATE
;
2399 c
->tb
= XCNEW (gfc_typebound_proc
);
2401 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2403 /* Add procedure pointers for type-bound procedures. */
2404 if (!derived
->attr
.unlimited_polymorphic
)
2405 add_procs_to_declared_vtab (derived
, vtype
);
2409 vtab
->ts
.u
.derived
= vtype
;
2410 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2417 /* It is unexpected to have some symbols added at resolution or code
2418 generation time. We commit the changes in order to keep a clean state. */
2421 gfc_commit_symbol (vtab
);
2423 gfc_commit_symbol (vtype
);
2425 gfc_commit_symbol (def_init
);
2427 gfc_commit_symbol (copy
);
2429 gfc_commit_symbol (src
);
2431 gfc_commit_symbol (dst
);
2434 gfc_undo_symbols ();
2440 /* Check if a derived type is finalizable. That is the case if it
2441 (1) has a FINAL subroutine or
2442 (2) has a nonpointer nonallocatable component of finalizable type.
2443 If it is finalizable, return an expression containing the
2444 finalization wrapper. */
2447 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2452 /* (1) Check for FINAL subroutines. */
2453 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2456 /* (2) Check for components of finalizable type. */
2457 for (c
= derived
->components
; c
; c
= c
->next
)
2458 if (c
->ts
.type
== BT_DERIVED
2459 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2460 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2466 /* Make sure vtab is generated. */
2467 vtab
= gfc_find_derived_vtab (derived
);
2470 /* Return finalizer expression. */
2471 gfc_component
*final
;
2472 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2473 gcc_assert (strcmp (final
->name
, "_final") == 0);
2474 gcc_assert (final
->initializer
2475 && final
->initializer
->expr_type
!= EXPR_NULL
);
2476 *final_expr
= final
->initializer
;
2482 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2483 needed to support unlimited polymorphism. */
2486 find_intrinsic_vtab (gfc_typespec
*ts
)
2489 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2490 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2493 if (ts
->type
== BT_CHARACTER
&& !ts
->deferred
&& ts
->u
.cl
&& ts
->u
.cl
->length
2494 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2495 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2497 /* Find the top-level namespace. */
2498 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2504 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2506 if (ts
->type
== BT_CHARACTER
)
2507 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2510 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2512 sprintf (name
, "__vtab_%s", tname
);
2514 /* Look for the vtab symbol in various namespaces. */
2515 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2517 gfc_find_symbol (name
, ns
, 0, &vtab
);
2521 gfc_get_symbol (name
, ns
, &vtab
);
2522 vtab
->ts
.type
= BT_DERIVED
;
2523 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2524 &gfc_current_locus
))
2526 vtab
->attr
.target
= 1;
2527 vtab
->attr
.save
= SAVE_IMPLICIT
;
2528 vtab
->attr
.vtab
= 1;
2529 vtab
->attr
.access
= ACCESS_PUBLIC
;
2530 gfc_set_sym_referenced (vtab
);
2531 sprintf (name
, "__vtype_%s", tname
);
2533 gfc_find_symbol (name
, ns
, 0, &vtype
);
2538 gfc_namespace
*sub_ns
;
2539 gfc_namespace
*contained
;
2542 gfc_get_symbol (name
, ns
, &vtype
);
2543 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2544 &gfc_current_locus
))
2546 vtype
->attr
.access
= ACCESS_PUBLIC
;
2547 vtype
->attr
.vtype
= 1;
2548 gfc_set_sym_referenced (vtype
);
2550 /* Add component '_hash'. */
2551 if (!gfc_add_component (vtype
, "_hash", &c
))
2553 c
->ts
.type
= BT_INTEGER
;
2555 c
->attr
.access
= ACCESS_PRIVATE
;
2556 hash
= gfc_intrinsic_hash_value (ts
);
2557 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2560 /* Add component '_size'. */
2561 if (!gfc_add_component (vtype
, "_size", &c
))
2563 c
->ts
.type
= BT_INTEGER
;
2565 c
->attr
.access
= ACCESS_PRIVATE
;
2567 /* Build a minimal expression to make use of
2568 target-memory.c/gfc_element_size for 'size'. Special handling
2569 for character arrays, that are not constant sized: to support
2570 len (str) * kind, only the kind information is stored in the
2572 e
= gfc_get_expr ();
2574 e
->expr_type
= EXPR_VARIABLE
;
2575 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2577 ts
->type
== BT_CHARACTER
2580 (int)gfc_element_size (e
));
2583 /* Add component _extends. */
2584 if (!gfc_add_component (vtype
, "_extends", &c
))
2586 c
->attr
.pointer
= 1;
2587 c
->attr
.access
= ACCESS_PRIVATE
;
2588 c
->ts
.type
= BT_VOID
;
2589 c
->initializer
= gfc_get_null_expr (NULL
);
2591 /* Add component _def_init. */
2592 if (!gfc_add_component (vtype
, "_def_init", &c
))
2594 c
->attr
.pointer
= 1;
2595 c
->attr
.access
= ACCESS_PRIVATE
;
2596 c
->ts
.type
= BT_VOID
;
2597 c
->initializer
= gfc_get_null_expr (NULL
);
2599 /* Add component _copy. */
2600 if (!gfc_add_component (vtype
, "_copy", &c
))
2602 c
->attr
.proc_pointer
= 1;
2603 c
->attr
.access
= ACCESS_PRIVATE
;
2604 c
->tb
= XCNEW (gfc_typebound_proc
);
2607 if (ts
->type
!= BT_CHARACTER
)
2608 sprintf (name
, "__copy_%s", tname
);
2611 /* __copy is always the same for characters.
2612 Check to see if copy function already exists. */
2613 sprintf (name
, "__copy_character_%d", ts
->kind
);
2614 contained
= ns
->contained
;
2615 for (; contained
; contained
= contained
->sibling
)
2616 if (contained
->proc_name
2617 && strcmp (name
, contained
->proc_name
->name
) == 0)
2619 copy
= contained
->proc_name
;
2624 /* Set up namespace. */
2625 sub_ns
= gfc_get_namespace (ns
, 0);
2626 sub_ns
->sibling
= ns
->contained
;
2627 ns
->contained
= sub_ns
;
2628 sub_ns
->resolved
= 1;
2629 /* Set up procedure symbol. */
2630 gfc_get_symbol (name
, sub_ns
, ©
);
2631 sub_ns
->proc_name
= copy
;
2632 copy
->attr
.flavor
= FL_PROCEDURE
;
2633 copy
->attr
.subroutine
= 1;
2634 copy
->attr
.pure
= 1;
2635 copy
->attr
.if_source
= IFSRC_DECL
;
2636 /* This is elemental so that arrays are automatically
2637 treated correctly by the scalarizer. */
2638 copy
->attr
.elemental
= 1;
2639 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2640 copy
->module
= ns
->proc_name
->name
;
2641 gfc_set_sym_referenced (copy
);
2642 /* Set up formal arguments. */
2643 gfc_get_symbol ("src", sub_ns
, &src
);
2644 src
->ts
.type
= ts
->type
;
2645 src
->ts
.kind
= ts
->kind
;
2646 src
->attr
.flavor
= FL_VARIABLE
;
2647 src
->attr
.dummy
= 1;
2648 src
->attr
.intent
= INTENT_IN
;
2649 gfc_set_sym_referenced (src
);
2650 copy
->formal
= gfc_get_formal_arglist ();
2651 copy
->formal
->sym
= src
;
2652 gfc_get_symbol ("dst", sub_ns
, &dst
);
2653 dst
->ts
.type
= ts
->type
;
2654 dst
->ts
.kind
= ts
->kind
;
2655 dst
->attr
.flavor
= FL_VARIABLE
;
2656 dst
->attr
.dummy
= 1;
2657 dst
->attr
.intent
= INTENT_INOUT
;
2658 gfc_set_sym_referenced (dst
);
2659 copy
->formal
->next
= gfc_get_formal_arglist ();
2660 copy
->formal
->next
->sym
= dst
;
2662 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2663 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2664 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2666 /* Set initializer. */
2667 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2668 c
->ts
.interface
= copy
;
2670 /* Add component _final. */
2671 if (!gfc_add_component (vtype
, "_final", &c
))
2673 c
->attr
.proc_pointer
= 1;
2674 c
->attr
.access
= ACCESS_PRIVATE
;
2675 c
->tb
= XCNEW (gfc_typebound_proc
);
2677 c
->initializer
= gfc_get_null_expr (NULL
);
2679 vtab
->ts
.u
.derived
= vtype
;
2680 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2687 /* It is unexpected to have some symbols added at resolution or code
2688 generation time. We commit the changes in order to keep a clean state. */
2691 gfc_commit_symbol (vtab
);
2693 gfc_commit_symbol (vtype
);
2695 gfc_commit_symbol (copy
);
2697 gfc_commit_symbol (src
);
2699 gfc_commit_symbol (dst
);
2702 gfc_undo_symbols ();
2708 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2711 gfc_find_vtab (gfc_typespec
*ts
)
2718 return gfc_find_derived_vtab (ts
->u
.derived
);
2720 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2722 return find_intrinsic_vtab (ts
);
2727 /* General worker function to find either a type-bound procedure or a
2728 type-bound user operator. */
2731 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2732 const char* name
, bool noaccess
, bool uop
,
2738 /* Set default to failure. */
2742 if (derived
->f2k_derived
)
2743 /* Set correct symbol-root. */
2744 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2745 : derived
->f2k_derived
->tb_sym_root
);
2749 /* Try to find it in the current type's namespace. */
2750 res
= gfc_find_symtree (root
, name
);
2751 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2757 if (!noaccess
&& derived
->attr
.use_assoc
2758 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2761 gfc_error ("%qs of %qs is PRIVATE at %L",
2762 name
, derived
->name
, where
);
2770 /* Otherwise, recurse on parent type if derived is an extension. */
2771 if (derived
->attr
.extension
)
2773 gfc_symbol
* super_type
;
2774 super_type
= gfc_get_derived_super_type (derived
);
2775 gcc_assert (super_type
);
2777 return find_typebound_proc_uop (super_type
, t
, name
,
2778 noaccess
, uop
, where
);
2781 /* Nothing found. */
2786 /* Find a type-bound procedure or user operator by name for a derived-type
2787 (looking recursively through the super-types). */
2790 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2791 const char* name
, bool noaccess
, locus
* where
)
2793 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2797 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2798 const char* name
, bool noaccess
, locus
* where
)
2800 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2804 /* Find a type-bound intrinsic operator looking recursively through the
2805 super-type hierarchy. */
2808 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2809 gfc_intrinsic_op op
, bool noaccess
,
2812 gfc_typebound_proc
* res
;
2814 /* Set default to failure. */
2818 /* Try to find it in the current type's namespace. */
2819 if (derived
->f2k_derived
)
2820 res
= derived
->f2k_derived
->tb_op
[op
];
2825 if (res
&& !res
->error
)
2831 if (!noaccess
&& derived
->attr
.use_assoc
2832 && res
->access
== ACCESS_PRIVATE
)
2835 gfc_error ("%qs of %qs is PRIVATE at %L",
2836 gfc_op2string (op
), derived
->name
, where
);
2844 /* Otherwise, recurse on parent type if derived is an extension. */
2845 if (derived
->attr
.extension
)
2847 gfc_symbol
* super_type
;
2848 super_type
= gfc_get_derived_super_type (derived
);
2849 gcc_assert (super_type
);
2851 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2855 /* Nothing found. */
2860 /* Get a typebound-procedure symtree or create and insert it if not yet
2861 present. This is like a very simplified version of gfc_get_sym_tree for
2862 tbp-symtrees rather than regular ones. */
2865 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2867 gfc_symtree
*result
;
2869 result
= gfc_find_symtree (*root
, name
);
2872 result
= gfc_new_symtree (root
, name
);
2873 gcc_assert (result
);
2874 result
->n
.tb
= NULL
;