1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2016 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 gfc_find_component (type_sym
, name
, true, true, &new_ref
);
82 gcc_assert (new_ref
->u
.c
.component
);
84 new_ref
= new_ref
->next
;
91 /* We need to update the base type in the trailing reference chain to
92 that of the new component. */
94 gcc_assert (strcmp (name
, "_data") == 0);
96 if (new_ref
->next
->type
== REF_COMPONENT
)
98 else if (new_ref
->next
->type
== REF_ARRAY
99 && new_ref
->next
->next
100 && new_ref
->next
->next
->type
== REF_COMPONENT
)
101 next
= new_ref
->next
->next
;
105 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
106 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
107 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
115 /* Tells whether we need to add a "_data" reference to access REF subobject
116 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
117 object accessed by REF is a variable; in other words it is a full object,
121 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
123 /* Only class containers may need the "_data" reference. */
124 if (ts
->type
!= BT_CLASS
)
127 /* Accessing a class container with an array reference is certainly wrong. */
128 if (ref
->type
!= REF_COMPONENT
)
131 /* Accessing the class container's fields is fine. */
132 if (ref
->u
.c
.component
->name
[0] == '_')
135 /* At this point we have a class container with a non class container's field
136 component reference. We don't want to add the "_data" component if we are
137 at the first reference and the symbol's type is an extended derived type.
138 In that case, conv_parent_component_references will do the right thing so
139 it is not absolutely necessary. Omitting it prevents a regression (see
140 class_41.f03) in the interface mapping mechanism. When evaluating string
141 lengths depending on dummy arguments, we create a fake symbol with a type
142 equal to that of the dummy type. However, because of type extension,
143 the backend type (corresponding to the actual argument) can have a
144 different (extended) type. Adding the "_data" component explicitly, using
145 the base type, confuses the gfc_conv_component_ref code which deals with
146 the extended type. */
147 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
150 /* We have a class container with a non class container's field component
151 reference that doesn't fall into the above. */
156 /* Browse through a data reference chain and add the missing "_data" references
157 when a subobject of a class object is accessed without it.
158 Note that it doesn't add the "_data" reference when the class container
159 is the last element in the reference chain. */
162 gfc_fix_class_refs (gfc_expr
*e
)
167 if ((e
->expr_type
!= EXPR_VARIABLE
168 && e
->expr_type
!= EXPR_FUNCTION
)
169 || (e
->expr_type
== EXPR_FUNCTION
170 && e
->value
.function
.isym
!= NULL
))
173 if (e
->expr_type
== EXPR_VARIABLE
)
174 ts
= &e
->symtree
->n
.sym
->ts
;
179 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
180 if (e
->value
.function
.esym
!= NULL
)
181 func
= e
->value
.function
.esym
;
183 func
= e
->symtree
->n
.sym
;
185 if (func
->result
!= NULL
)
186 ts
= &func
->result
->ts
;
191 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
193 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
194 insert_component_ref (ts
, ref
, "_data");
196 if ((*ref
)->type
== REF_COMPONENT
)
197 ts
= &(*ref
)->u
.c
.component
->ts
;
202 /* Insert a reference to the component of the given name.
203 Only to be used with CLASS containers and vtables. */
206 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
209 gfc_ref
**tail
= &(e
->ref
);
210 gfc_ref
*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 c
= gfc_find_component (derived
, name
, true, true, tail
);
243 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
252 /* This is used to add both the _data component reference and an array
253 reference to class expressions. Used in translation of intrinsic
254 array inquiry functions. */
257 gfc_add_class_array_ref (gfc_expr
*e
)
259 int rank
= CLASS_DATA (e
)->as
->rank
;
260 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
262 gfc_add_data_component (e
);
264 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
267 if (ref
->type
!= REF_ARRAY
)
269 ref
->next
= gfc_get_ref ();
271 ref
->type
= REF_ARRAY
;
272 ref
->u
.ar
.type
= AR_FULL
;
278 /* Unfortunately, class array expressions can appear in various conditions;
279 with and without both _data component and an arrayspec. This function
280 deals with that variability. The previous reference to 'ref' is to a
284 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
286 bool no_data
= false;
287 bool with_data
= false;
289 /* An array reference with no _data component. */
290 if (ref
&& ref
->type
== REF_ARRAY
292 && ref
->u
.ar
.type
!= AR_ELEMENT
)
295 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
299 /* Cover cases where _data appears, with or without an array ref. */
300 if (ref
&& ref
->type
== REF_COMPONENT
301 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
309 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
311 && ref
->type
== REF_COMPONENT
312 && ref
->next
->type
== REF_ARRAY
313 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
317 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
321 return no_data
|| with_data
;
325 /* Returns true if the expression contains a reference to a class
326 array. Notice that class array elements return false. */
329 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
339 /* Is this a class array object? ie. Is the symbol of type class? */
341 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
342 && CLASS_DATA (e
->symtree
->n
.sym
)
343 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
344 && class_array_ref_detected (e
->ref
, full_array
))
347 /* Or is this a class array component reference? */
348 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
350 if (ref
->type
== REF_COMPONENT
351 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
352 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
353 && class_array_ref_detected (ref
->next
, full_array
))
361 /* Returns true if the expression is a reference to a class
362 scalar. This function is necessary because such expressions
363 can be dressed with a reference to the _data component and so
364 have a type other than BT_CLASS. */
367 gfc_is_class_scalar_expr (gfc_expr
*e
)
374 /* Is this a class object? */
376 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
377 && CLASS_DATA (e
->symtree
->n
.sym
)
378 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
380 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
381 && e
->ref
->next
== NULL
)))
384 /* Or is the final reference BT_CLASS or _data? */
385 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
387 if (ref
->type
== REF_COMPONENT
388 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
389 && CLASS_DATA (ref
->u
.c
.component
)
390 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
391 && (ref
->next
== NULL
392 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
393 && ref
->next
->next
== NULL
)))
401 /* Tells whether the expression E is a reference to a (scalar) class container.
402 Scalar because array class containers usually have an array reference after
403 them, and gfc_fix_class_refs will add the missing "_data" component reference
407 gfc_is_class_container_ref (gfc_expr
*e
)
412 if (e
->expr_type
!= EXPR_VARIABLE
)
413 return e
->ts
.type
== BT_CLASS
;
415 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
420 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
422 if (ref
->type
!= REF_COMPONENT
)
424 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
434 /* Build an initializer for CLASS pointers,
435 initializing the _data component to the init_expr (or NULL) and the _vptr
436 component to the corresponding type (or the declared type, given by ts). */
439 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
443 gfc_symbol
*vtab
= NULL
;
445 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
446 vtab
= gfc_find_vtab (&init_expr
->ts
);
448 vtab
= gfc_find_vtab (ts
);
450 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
451 &ts
->u
.derived
->declared_at
);
454 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
456 gfc_constructor
*ctor
= gfc_constructor_get();
457 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
458 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
459 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
460 ctor
->expr
= gfc_copy_expr (init_expr
);
462 ctor
->expr
= gfc_get_null_expr (NULL
);
463 gfc_constructor_append (&init
->value
.constructor
, ctor
);
470 /* Create a unique string identifier for a derived type, composed of its name
471 and module name. This is used to construct unique names for the class
472 containers and vtab symbols. */
475 get_unique_type_string (char *string
, gfc_symbol
*derived
)
477 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
478 if (derived
->attr
.unlimited_polymorphic
)
479 strcpy (dt_name
, "STAR");
481 strcpy (dt_name
, gfc_dt_upper_string (derived
->name
));
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_len_component (ptr
);
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
;
710 c
->ts
.kind
= gfc_charlen_int_kind
;
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, NULL
);
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, NULL
))
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 /* Stop infinite recursion through this function by inhibiting
847 calls when the derived type and that of the component are
849 if (c
->ts
.type
== BT_DERIVED
850 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
851 && !c
->attr
.pointer
&& !c
->attr
.allocatable
852 && has_finalizer_component (c
->ts
.u
.derived
))
860 comp_is_finalizable (gfc_component
*comp
)
862 if (comp
->attr
.proc_pointer
)
864 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
866 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
867 && (comp
->ts
.u
.derived
->attr
.alloc_comp
868 || has_finalizer_component (comp
->ts
.u
.derived
)
869 || (comp
->ts
.u
.derived
->f2k_derived
870 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
872 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
873 && CLASS_DATA (comp
)->attr
.allocatable
)
880 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
881 neither allocatable nor a pointer but has a finalizer, call it. If it
882 is a nonpointer component with allocatable components or has finalizers, walk
883 them. Either of them is required; other nonallocatables and pointers aren't
885 Note: If the component is allocatable, the DEALLOCATE handling takes care
886 of calling the appropriate finalizers, coarray deregistering, and
887 deallocation of allocatable subcomponents. */
890 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
891 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
892 gfc_namespace
*sub_ns
)
897 if (!comp_is_finalizable (comp
))
900 e
= gfc_copy_expr (expr
);
902 e
->ref
= ref
= gfc_get_ref ();
905 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
907 ref
->next
= gfc_get_ref ();
910 ref
->type
= REF_COMPONENT
;
911 ref
->u
.c
.sym
= derived
;
912 ref
->u
.c
.component
= comp
;
915 if (comp
->attr
.dimension
|| comp
->attr
.codimension
916 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
917 && (CLASS_DATA (comp
)->attr
.dimension
918 || CLASS_DATA (comp
)->attr
.codimension
)))
920 ref
->next
= gfc_get_ref ();
921 ref
->next
->type
= REF_ARRAY
;
922 ref
->next
->u
.ar
.dimen
= 0;
923 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
925 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
926 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
929 /* Call DEALLOCATE (comp, stat=ignore). */
930 if (comp
->attr
.allocatable
931 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
932 && CLASS_DATA (comp
)->attr
.allocatable
))
934 gfc_code
*dealloc
, *block
= NULL
;
936 /* Add IF (fini_coarray). */
937 if (comp
->attr
.codimension
938 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
939 && CLASS_DATA (comp
)->attr
.codimension
))
941 block
= gfc_get_code (EXEC_IF
);
944 (*code
)->next
= block
;
945 (*code
) = (*code
)->next
;
950 block
->block
= gfc_get_code (EXEC_IF
);
951 block
= block
->block
;
952 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
955 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
957 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
958 dealloc
->ext
.alloc
.list
->expr
= e
;
959 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
961 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
962 cond
->block
= gfc_get_code (EXEC_IF
);
963 cond
->block
->expr1
= gfc_get_expr ();
964 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
965 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
966 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
967 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
968 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
969 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
970 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
971 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
972 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
973 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
974 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
975 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
976 cond
->block
->next
= dealloc
;
982 (*code
)->next
= cond
;
983 (*code
) = (*code
)->next
;
988 else if (comp
->ts
.type
== BT_DERIVED
989 && comp
->ts
.u
.derived
->f2k_derived
990 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
992 /* Call FINAL_WRAPPER (comp); */
993 gfc_code
*final_wrap
;
997 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
998 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
999 if (strcmp (c
->name
, "_final") == 0)
1003 final_wrap
= gfc_get_code (EXEC_CALL
);
1004 final_wrap
->symtree
= c
->initializer
->symtree
;
1005 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1006 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1007 final_wrap
->ext
.actual
->expr
= e
;
1011 (*code
)->next
= final_wrap
;
1012 (*code
) = (*code
)->next
;
1015 (*code
) = final_wrap
;
1021 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1022 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1029 /* Generate code equivalent to
1030 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1031 + offset, c_ptr), ptr). */
1034 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1035 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1038 gfc_expr
*expr
, *expr2
;
1040 /* C_F_POINTER(). */
1041 block
= gfc_get_code (EXEC_CALL
);
1042 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1043 block
->resolved_sym
= block
->symtree
->n
.sym
;
1044 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1045 block
->resolved_sym
->attr
.intrinsic
= 1;
1046 block
->resolved_sym
->attr
.subroutine
= 1;
1047 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1048 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1049 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1050 gfc_commit_symbol (block
->resolved_sym
);
1052 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1053 block
->ext
.actual
= gfc_get_actual_arglist ();
1054 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1055 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1057 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1059 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1061 /* TRANSFER's first argument: C_LOC (array). */
1062 expr
= gfc_get_expr ();
1063 expr
->expr_type
= EXPR_FUNCTION
;
1064 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1065 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1066 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1067 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1068 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1069 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1070 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1071 expr
->value
.function
.actual
->expr
1072 = gfc_lval_expr_from_sym (array
);
1073 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1074 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1075 expr
->ts
.type
= BT_INTEGER
;
1076 expr
->ts
.kind
= gfc_index_integer_kind
;
1079 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1080 gfc_current_locus
, 3, expr
,
1081 gfc_get_int_expr (gfc_index_integer_kind
,
1083 expr2
->ts
.type
= BT_INTEGER
;
1084 expr2
->ts
.kind
= gfc_index_integer_kind
;
1086 /* <array addr> + <offset>. */
1087 block
->ext
.actual
->expr
= gfc_get_expr ();
1088 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1089 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1090 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1091 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1092 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1094 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1095 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1096 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1097 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1103 /* Calculates the offset to the (idx+1)th element of an array, taking the
1104 stride into account. It generates the code:
1107 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1109 offset = offset * byte_stride. */
1112 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1113 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1114 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1115 gfc_code
*block
, gfc_namespace
*sub_ns
)
1118 gfc_expr
*expr
, *expr2
;
1121 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1122 block
= block
->next
;
1123 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1124 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1127 iter
= gfc_get_iterator ();
1128 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1129 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1130 iter
->end
= gfc_copy_expr (rank
);
1131 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1132 block
->next
= gfc_get_code (EXEC_DO
);
1133 block
= block
->next
;
1134 block
->ext
.iterator
= iter
;
1135 block
->block
= gfc_get_code (EXEC_DO
);
1137 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1140 /* mod (idx, sizes(idx2)). */
1141 expr
= gfc_lval_expr_from_sym (sizes
);
1142 expr
->ref
= gfc_get_ref ();
1143 expr
->ref
->type
= REF_ARRAY
;
1144 expr
->ref
->u
.ar
.as
= sizes
->as
;
1145 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1146 expr
->ref
->u
.ar
.dimen
= 1;
1147 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1148 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1150 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1151 gfc_current_locus
, 2,
1152 gfc_lval_expr_from_sym (idx
), expr
);
1155 /* (...) / sizes(idx2-1). */
1156 expr2
= gfc_get_expr ();
1157 expr2
->expr_type
= EXPR_OP
;
1158 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1159 expr2
->value
.op
.op1
= expr
;
1160 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1161 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1162 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1163 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1164 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1165 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1166 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1167 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1168 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1169 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1170 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1171 = gfc_lval_expr_from_sym (idx2
);
1172 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1173 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1174 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1175 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1176 expr2
->ts
= idx
->ts
;
1178 /* ... * strides(idx2). */
1179 expr
= gfc_get_expr ();
1180 expr
->expr_type
= EXPR_OP
;
1181 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1182 expr
->value
.op
.op1
= expr2
;
1183 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1184 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1185 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1186 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1187 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1188 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1189 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1190 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1193 /* offset = offset + ... */
1194 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1195 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1196 block
->block
->next
->expr2
= gfc_get_expr ();
1197 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1198 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1199 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1200 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1201 block
->block
->next
->expr2
->ts
= idx
->ts
;
1203 /* After the loop: offset = offset * byte_stride. */
1204 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1205 block
= block
->next
;
1206 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1207 block
->expr2
= gfc_get_expr ();
1208 block
->expr2
->expr_type
= EXPR_OP
;
1209 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1210 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1211 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1212 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1217 /* Insert code of the following form:
1220 integer(c_intptr_t) :: i
1222 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1223 && (is_contiguous || !final_rank3->attr.contiguous
1224 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1225 || 0 == STORAGE_SIZE (array)) then
1226 call final_rank3 (array)
1229 integer(c_intptr_t) :: offset, j
1230 type(t) :: tmp(shape (array))
1232 do i = 0, size (array)-1
1233 offset = obtain_offset(i, strides, sizes, byte_stride)
1234 addr = transfer (c_loc (array), addr) + offset
1235 call c_f_pointer (transfer (addr, cptr), ptr)
1237 addr = transfer (c_loc (tmp), addr)
1238 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1239 call c_f_pointer (transfer (addr, cptr), ptr2)
1242 call final_rank3 (tmp)
1248 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1249 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1250 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1252 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1253 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1254 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1255 gfc_namespace
*sub_ns
)
1257 gfc_symbol
*tmp_array
, *ptr2
;
1258 gfc_expr
*size_expr
, *offset2
, *expr
;
1264 block
->next
= gfc_get_code (EXEC_IF
);
1265 block
= block
->next
;
1267 block
->block
= gfc_get_code (EXEC_IF
);
1268 block
= block
->block
;
1270 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1271 size_expr
= gfc_get_expr ();
1272 size_expr
->where
= gfc_current_locus
;
1273 size_expr
->expr_type
= EXPR_OP
;
1274 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1276 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1277 size_expr
->value
.op
.op1
1278 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1279 "storage_size", gfc_current_locus
, 2,
1280 gfc_lval_expr_from_sym (array
),
1281 gfc_get_int_expr (gfc_index_integer_kind
,
1284 /* NUMERIC_STORAGE_SIZE. */
1285 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1286 gfc_character_storage_size
);
1287 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1288 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1290 /* IF condition: (stride == size_expr
1291 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1293 || 0 == size_expr. */
1294 block
->expr1
= gfc_get_expr ();
1295 block
->expr1
->ts
.type
= BT_LOGICAL
;
1296 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1297 block
->expr1
->expr_type
= EXPR_OP
;
1298 block
->expr1
->where
= gfc_current_locus
;
1300 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1302 /* byte_stride == size_expr */
1303 expr
= gfc_get_expr ();
1304 expr
->ts
.type
= BT_LOGICAL
;
1305 expr
->ts
.kind
= gfc_default_logical_kind
;
1306 expr
->expr_type
= EXPR_OP
;
1307 expr
->where
= gfc_current_locus
;
1308 expr
->value
.op
.op
= INTRINSIC_EQ
;
1310 = gfc_lval_expr_from_sym (byte_stride
);
1311 expr
->value
.op
.op2
= size_expr
;
1313 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1314 add is_contiguous check. */
1316 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1317 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1320 expr2
= gfc_get_expr ();
1321 expr2
->ts
.type
= BT_LOGICAL
;
1322 expr2
->ts
.kind
= gfc_default_logical_kind
;
1323 expr2
->expr_type
= EXPR_OP
;
1324 expr2
->where
= gfc_current_locus
;
1325 expr2
->value
.op
.op
= INTRINSIC_AND
;
1326 expr2
->value
.op
.op1
= expr
;
1327 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1331 block
->expr1
->value
.op
.op1
= expr
;
1333 /* 0 == size_expr */
1334 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1335 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1336 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1337 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1338 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1339 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1340 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1341 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1342 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1344 /* IF body: call final subroutine. */
1345 block
->next
= gfc_get_code (EXEC_CALL
);
1346 block
->next
->symtree
= fini
->proc_tree
;
1347 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1348 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1349 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1350 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1351 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1355 block
->block
= gfc_get_code (EXEC_IF
);
1356 block
= block
->block
;
1358 /* BLOCK ... END BLOCK. */
1359 block
->next
= gfc_get_code (EXEC_BLOCK
);
1360 block
= block
->next
;
1362 ns
= gfc_build_block_ns (sub_ns
);
1363 block
->ext
.block
.ns
= ns
;
1364 block
->ext
.block
.assoc
= NULL
;
1366 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1367 ptr2
->ts
.type
= BT_DERIVED
;
1368 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1369 ptr2
->attr
.flavor
= FL_VARIABLE
;
1370 ptr2
->attr
.pointer
= 1;
1371 ptr2
->attr
.artificial
= 1;
1372 gfc_set_sym_referenced (ptr2
);
1373 gfc_commit_symbol (ptr2
);
1375 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1376 tmp_array
->ts
.type
= BT_DERIVED
;
1377 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1378 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1379 tmp_array
->attr
.dimension
= 1;
1380 tmp_array
->attr
.artificial
= 1;
1381 tmp_array
->as
= gfc_get_array_spec();
1382 tmp_array
->attr
.intent
= INTENT_INOUT
;
1383 tmp_array
->as
->type
= AS_EXPLICIT
;
1384 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1386 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1388 gfc_expr
*shape_expr
;
1389 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1391 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1393 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1394 gfc_current_locus
, 3,
1395 gfc_lval_expr_from_sym (array
),
1396 gfc_get_int_expr (gfc_default_integer_kind
,
1398 gfc_get_int_expr (gfc_default_integer_kind
,
1400 gfc_index_integer_kind
));
1401 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1402 tmp_array
->as
->upper
[i
] = shape_expr
;
1404 gfc_set_sym_referenced (tmp_array
);
1405 gfc_commit_symbol (tmp_array
);
1408 iter
= gfc_get_iterator ();
1409 iter
->var
= gfc_lval_expr_from_sym (idx
);
1410 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1411 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1412 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1414 block
= gfc_get_code (EXEC_DO
);
1416 block
->ext
.iterator
= iter
;
1417 block
->block
= gfc_get_code (EXEC_DO
);
1419 /* Offset calculation for the new array: idx * size of type (in bytes). */
1420 offset2
= gfc_get_expr ();
1421 offset2
->expr_type
= EXPR_OP
;
1422 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1423 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1424 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1425 offset2
->ts
= byte_stride
->ts
;
1427 /* Offset calculation of "array". */
1428 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1429 byte_stride
, rank
, block
->block
, sub_ns
);
1432 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1433 + idx * stride, c_ptr), ptr). */
1434 block2
->next
= finalization_scalarizer (array
, ptr
,
1435 gfc_lval_expr_from_sym (offset
),
1437 block2
= block2
->next
;
1438 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1439 block2
= block2
->next
;
1442 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1443 block2
= block2
->next
;
1444 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1445 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1447 /* Call now the user's final subroutine. */
1448 block
->next
= gfc_get_code (EXEC_CALL
);
1449 block
= block
->next
;
1450 block
->symtree
= fini
->proc_tree
;
1451 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1452 block
->ext
.actual
= gfc_get_actual_arglist ();
1453 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1455 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1461 iter
= gfc_get_iterator ();
1462 iter
->var
= gfc_lval_expr_from_sym (idx
);
1463 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1464 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1465 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1467 block
->next
= gfc_get_code (EXEC_DO
);
1468 block
= block
->next
;
1469 block
->ext
.iterator
= iter
;
1470 block
->block
= gfc_get_code (EXEC_DO
);
1472 /* Offset calculation of "array". */
1473 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1474 byte_stride
, rank
, block
->block
, sub_ns
);
1477 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1478 + offset, c_ptr), ptr). */
1479 block2
->next
= finalization_scalarizer (array
, ptr
,
1480 gfc_lval_expr_from_sym (offset
),
1482 block2
= block2
->next
;
1483 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1484 gfc_copy_expr (offset2
), sub_ns
);
1485 block2
= block2
->next
;
1488 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1489 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1490 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1494 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1495 derived type "derived". The function first calls the approriate FINAL
1496 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1497 components (but not the inherited ones). Last, it calls the wrapper
1498 subroutine of the parent. The generated wrapper procedure takes as argument
1499 an assumed-rank array.
1500 If neither allocatable components nor FINAL subroutines exists, the vtab
1501 will contain a NULL pointer.
1502 The generated function has the form
1503 _final(assumed-rank array, stride, skip_corarray)
1504 where the array has to be contiguous (except of the lowest dimension). The
1505 stride (in bytes) is used to allow different sizes for ancestor types by
1506 skipping over the additionally added components in the scalarizer. If
1507 "fini_coarray" is false, coarray components are not finalized to allow for
1508 the correct semantic with intrinsic assignment. */
1511 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1512 const char *tname
, gfc_component
*vtab_final
)
1514 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1515 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1516 gfc_component
*comp
;
1517 gfc_namespace
*sub_ns
;
1518 gfc_code
*last_code
, *block
;
1519 char name
[GFC_MAX_SYMBOL_LEN
+1];
1520 bool finalizable_comp
= false;
1521 bool expr_null_wrapper
= false;
1522 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1525 if (derived
->attr
.unlimited_polymorphic
)
1527 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1531 /* Search for the ancestor's finalizers. */
1532 if (derived
->attr
.extension
&& derived
->components
1533 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1534 || has_finalizer_component (derived
)))
1537 gfc_component
*comp
;
1539 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1540 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1541 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1543 ancestor_wrapper
= comp
->initializer
;
1548 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1549 components: Return a NULL() expression; we defer this a bit to have have
1550 an interface declaration. */
1551 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1552 && !derived
->attr
.alloc_comp
1553 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1554 && !has_finalizer_component (derived
))
1555 expr_null_wrapper
= true;
1557 /* Check whether there are new allocatable components. */
1558 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1560 if (comp
== derived
->components
&& derived
->attr
.extension
1561 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1564 finalizable_comp
|= comp_is_finalizable (comp
);
1567 /* If there is no new finalizer and no new allocatable, return with
1568 an expr to the ancestor's one. */
1569 if (!expr_null_wrapper
&& !finalizable_comp
1570 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1572 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1573 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1574 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1575 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1579 /* We now create a wrapper, which does the following:
1580 1. Call the suitable finalization subroutine for this type
1581 2. Loop over all noninherited allocatable components and noninherited
1582 components with allocatable components and DEALLOCATE those; this will
1583 take care of finalizers, coarray deregistering and allocatable
1585 3. Call the ancestor's finalizer. */
1587 /* Declare the wrapper function; it takes an assumed-rank array
1588 and a VALUE logical as arguments. */
1590 /* Set up the namespace. */
1591 sub_ns
= gfc_get_namespace (ns
, 0);
1592 sub_ns
->sibling
= ns
->contained
;
1593 if (!expr_null_wrapper
)
1594 ns
->contained
= sub_ns
;
1595 sub_ns
->resolved
= 1;
1597 /* Set up the procedure symbol. */
1598 sprintf (name
, "__final_%s", tname
);
1599 gfc_get_symbol (name
, sub_ns
, &final
);
1600 sub_ns
->proc_name
= final
;
1601 final
->attr
.flavor
= FL_PROCEDURE
;
1602 final
->attr
.function
= 1;
1603 final
->attr
.pure
= 0;
1604 final
->result
= final
;
1605 final
->ts
.type
= BT_INTEGER
;
1607 final
->attr
.artificial
= 1;
1608 final
->attr
.always_explicit
= 1;
1609 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1610 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1611 final
->module
= ns
->proc_name
->name
;
1612 gfc_set_sym_referenced (final
);
1613 gfc_commit_symbol (final
);
1615 /* Set up formal argument. */
1616 gfc_get_symbol ("array", sub_ns
, &array
);
1617 array
->ts
.type
= BT_DERIVED
;
1618 array
->ts
.u
.derived
= derived
;
1619 array
->attr
.flavor
= FL_VARIABLE
;
1620 array
->attr
.dummy
= 1;
1621 array
->attr
.contiguous
= 1;
1622 array
->attr
.dimension
= 1;
1623 array
->attr
.artificial
= 1;
1624 array
->as
= gfc_get_array_spec();
1625 array
->as
->type
= AS_ASSUMED_RANK
;
1626 array
->as
->rank
= -1;
1627 array
->attr
.intent
= INTENT_INOUT
;
1628 gfc_set_sym_referenced (array
);
1629 final
->formal
= gfc_get_formal_arglist ();
1630 final
->formal
->sym
= array
;
1631 gfc_commit_symbol (array
);
1633 /* Set up formal argument. */
1634 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1635 byte_stride
->ts
.type
= BT_INTEGER
;
1636 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1637 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1638 byte_stride
->attr
.dummy
= 1;
1639 byte_stride
->attr
.value
= 1;
1640 byte_stride
->attr
.artificial
= 1;
1641 gfc_set_sym_referenced (byte_stride
);
1642 final
->formal
->next
= gfc_get_formal_arglist ();
1643 final
->formal
->next
->sym
= byte_stride
;
1644 gfc_commit_symbol (byte_stride
);
1646 /* Set up formal argument. */
1647 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1648 fini_coarray
->ts
.type
= BT_LOGICAL
;
1649 fini_coarray
->ts
.kind
= 1;
1650 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1651 fini_coarray
->attr
.dummy
= 1;
1652 fini_coarray
->attr
.value
= 1;
1653 fini_coarray
->attr
.artificial
= 1;
1654 gfc_set_sym_referenced (fini_coarray
);
1655 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1656 final
->formal
->next
->next
->sym
= fini_coarray
;
1657 gfc_commit_symbol (fini_coarray
);
1659 /* Return with a NULL() expression but with an interface which has
1660 the formal arguments. */
1661 if (expr_null_wrapper
)
1663 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1664 vtab_final
->ts
.interface
= final
;
1668 /* Local variables. */
1670 gfc_get_symbol ("idx", sub_ns
, &idx
);
1671 idx
->ts
.type
= BT_INTEGER
;
1672 idx
->ts
.kind
= gfc_index_integer_kind
;
1673 idx
->attr
.flavor
= FL_VARIABLE
;
1674 idx
->attr
.artificial
= 1;
1675 gfc_set_sym_referenced (idx
);
1676 gfc_commit_symbol (idx
);
1678 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1679 idx2
->ts
.type
= BT_INTEGER
;
1680 idx2
->ts
.kind
= gfc_index_integer_kind
;
1681 idx2
->attr
.flavor
= FL_VARIABLE
;
1682 idx2
->attr
.artificial
= 1;
1683 gfc_set_sym_referenced (idx2
);
1684 gfc_commit_symbol (idx2
);
1686 gfc_get_symbol ("offset", sub_ns
, &offset
);
1687 offset
->ts
.type
= BT_INTEGER
;
1688 offset
->ts
.kind
= gfc_index_integer_kind
;
1689 offset
->attr
.flavor
= FL_VARIABLE
;
1690 offset
->attr
.artificial
= 1;
1691 gfc_set_sym_referenced (offset
);
1692 gfc_commit_symbol (offset
);
1694 /* Create RANK expression. */
1695 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1696 gfc_current_locus
, 1,
1697 gfc_lval_expr_from_sym (array
));
1698 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1699 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1701 /* Create is_contiguous variable. */
1702 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1703 is_contiguous
->ts
.type
= BT_LOGICAL
;
1704 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1705 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1706 is_contiguous
->attr
.artificial
= 1;
1707 gfc_set_sym_referenced (is_contiguous
);
1708 gfc_commit_symbol (is_contiguous
);
1710 /* Create "sizes(0..rank)" variable, which contains the multiplied
1711 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1712 sizes(2) = sizes(1) * extent(dim=2) etc. */
1713 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1714 sizes
->ts
.type
= BT_INTEGER
;
1715 sizes
->ts
.kind
= gfc_index_integer_kind
;
1716 sizes
->attr
.flavor
= FL_VARIABLE
;
1717 sizes
->attr
.dimension
= 1;
1718 sizes
->attr
.artificial
= 1;
1719 sizes
->as
= gfc_get_array_spec();
1720 sizes
->attr
.intent
= INTENT_INOUT
;
1721 sizes
->as
->type
= AS_EXPLICIT
;
1722 sizes
->as
->rank
= 1;
1723 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1724 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1725 gfc_set_sym_referenced (sizes
);
1726 gfc_commit_symbol (sizes
);
1728 /* Create "strides(1..rank)" variable, which contains the strides per
1730 gfc_get_symbol ("strides", sub_ns
, &strides
);
1731 strides
->ts
.type
= BT_INTEGER
;
1732 strides
->ts
.kind
= gfc_index_integer_kind
;
1733 strides
->attr
.flavor
= FL_VARIABLE
;
1734 strides
->attr
.dimension
= 1;
1735 strides
->attr
.artificial
= 1;
1736 strides
->as
= gfc_get_array_spec();
1737 strides
->attr
.intent
= INTENT_INOUT
;
1738 strides
->as
->type
= AS_EXPLICIT
;
1739 strides
->as
->rank
= 1;
1740 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1741 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1742 gfc_set_sym_referenced (strides
);
1743 gfc_commit_symbol (strides
);
1746 /* Set return value to 0. */
1747 last_code
= gfc_get_code (EXEC_ASSIGN
);
1748 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1749 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1750 sub_ns
->code
= last_code
;
1752 /* Set: is_contiguous = .true. */
1753 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1754 last_code
= last_code
->next
;
1755 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1756 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1757 &gfc_current_locus
, true);
1759 /* Set: sizes(0) = 1. */
1760 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1761 last_code
= last_code
->next
;
1762 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1763 last_code
->expr1
->ref
= gfc_get_ref ();
1764 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1765 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1766 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1767 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1768 last_code
->expr1
->ref
->u
.ar
.start
[0]
1769 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1770 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1771 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1775 strides(idx) = _F._stride (array, dim=idx)
1776 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1777 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1781 iter
= gfc_get_iterator ();
1782 iter
->var
= gfc_lval_expr_from_sym (idx
);
1783 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1784 iter
->end
= gfc_copy_expr (rank
);
1785 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1786 last_code
->next
= gfc_get_code (EXEC_DO
);
1787 last_code
= last_code
->next
;
1788 last_code
->ext
.iterator
= iter
;
1789 last_code
->block
= gfc_get_code (EXEC_DO
);
1791 /* strides(idx) = _F._stride(array,dim=idx). */
1792 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1793 block
= last_code
->block
->next
;
1795 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1796 block
->expr1
->ref
= gfc_get_ref ();
1797 block
->expr1
->ref
->type
= REF_ARRAY
;
1798 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1799 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1800 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1801 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1802 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1804 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1805 gfc_current_locus
, 2,
1806 gfc_lval_expr_from_sym (array
),
1807 gfc_lval_expr_from_sym (idx
));
1809 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1810 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1811 block
= block
->next
;
1813 /* sizes(idx) = ... */
1814 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1815 block
->expr1
->ref
= gfc_get_ref ();
1816 block
->expr1
->ref
->type
= REF_ARRAY
;
1817 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1818 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1819 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1820 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1821 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1823 block
->expr2
= gfc_get_expr ();
1824 block
->expr2
->expr_type
= EXPR_OP
;
1825 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1828 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1829 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1830 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1831 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1832 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1833 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1834 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1835 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1836 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1837 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1838 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1839 = gfc_lval_expr_from_sym (idx
);
1840 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1841 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1842 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1843 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1845 /* size(array, dim=idx, kind=index_kind). */
1846 block
->expr2
->value
.op
.op2
1847 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1848 gfc_current_locus
, 3,
1849 gfc_lval_expr_from_sym (array
),
1850 gfc_lval_expr_from_sym (idx
),
1851 gfc_get_int_expr (gfc_index_integer_kind
,
1853 gfc_index_integer_kind
));
1854 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1855 block
->expr2
->ts
= idx
->ts
;
1857 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1858 block
->next
= gfc_get_code (EXEC_IF
);
1859 block
= block
->next
;
1861 block
->block
= gfc_get_code (EXEC_IF
);
1862 block
= block
->block
;
1864 /* if condition: strides(idx) /= sizes(idx-1). */
1865 block
->expr1
= gfc_get_expr ();
1866 block
->expr1
->ts
.type
= BT_LOGICAL
;
1867 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1868 block
->expr1
->expr_type
= EXPR_OP
;
1869 block
->expr1
->where
= gfc_current_locus
;
1870 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1872 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1873 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1874 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1875 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1876 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1877 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1878 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1879 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1881 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1882 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1883 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1884 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1885 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1886 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1887 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1888 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1889 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1890 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1891 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1892 = gfc_lval_expr_from_sym (idx
);
1893 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1894 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1895 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1896 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1898 /* if body: is_contiguous = .false. */
1899 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1900 block
= block
->next
;
1901 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1902 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1903 &gfc_current_locus
, false);
1905 /* Obtain the size (number of elements) of "array" MINUS ONE,
1906 which is used in the scalarization. */
1907 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1908 nelem
->ts
.type
= BT_INTEGER
;
1909 nelem
->ts
.kind
= gfc_index_integer_kind
;
1910 nelem
->attr
.flavor
= FL_VARIABLE
;
1911 nelem
->attr
.artificial
= 1;
1912 gfc_set_sym_referenced (nelem
);
1913 gfc_commit_symbol (nelem
);
1915 /* nelem = sizes (rank) - 1. */
1916 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1917 last_code
= last_code
->next
;
1919 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1921 last_code
->expr2
= gfc_get_expr ();
1922 last_code
->expr2
->expr_type
= EXPR_OP
;
1923 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1924 last_code
->expr2
->value
.op
.op2
1925 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1926 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1928 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1929 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1930 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1931 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1932 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1933 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1934 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1935 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1937 /* Call final subroutines. We now generate code like:
1939 integer, pointer :: ptr
1941 integer(c_intptr_t) :: i, addr
1943 select case (rank (array))
1945 ! If needed, the array is packed
1946 call final_rank3 (array)
1948 do i = 0, size (array)-1
1949 addr = transfer (c_loc (array), addr) + i * stride
1950 call c_f_pointer (transfer (addr, cptr), ptr)
1951 call elemental_final (ptr)
1955 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1957 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1959 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1960 ptr
->ts
.type
= BT_DERIVED
;
1961 ptr
->ts
.u
.derived
= derived
;
1962 ptr
->attr
.flavor
= FL_VARIABLE
;
1963 ptr
->attr
.pointer
= 1;
1964 ptr
->attr
.artificial
= 1;
1965 gfc_set_sym_referenced (ptr
);
1966 gfc_commit_symbol (ptr
);
1968 /* SELECT CASE (RANK (array)). */
1969 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1970 last_code
= last_code
->next
;
1971 last_code
->expr1
= gfc_copy_expr (rank
);
1974 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1976 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1977 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1983 /* CASE (fini_rank). */
1986 block
->block
= gfc_get_code (EXEC_SELECT
);
1987 block
= block
->block
;
1991 block
= gfc_get_code (EXEC_SELECT
);
1992 last_code
->block
= block
;
1994 block
->ext
.block
.case_list
= gfc_get_case ();
1995 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1996 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1997 block
->ext
.block
.case_list
->low
1998 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1999 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2001 block
->ext
.block
.case_list
->low
2002 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2003 block
->ext
.block
.case_list
->high
2004 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2006 /* CALL fini_rank (array) - possibly with packing. */
2007 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2008 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2009 idx
, ptr
, nelem
, strides
,
2010 sizes
, idx2
, offset
, is_contiguous
,
2014 block
->next
= gfc_get_code (EXEC_CALL
);
2015 block
->next
->symtree
= fini
->proc_tree
;
2016 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2017 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2018 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2022 /* Elemental call - scalarized. */
2028 block
->block
= gfc_get_code (EXEC_SELECT
);
2029 block
= block
->block
;
2033 block
= gfc_get_code (EXEC_SELECT
);
2034 last_code
->block
= block
;
2036 block
->ext
.block
.case_list
= gfc_get_case ();
2039 iter
= gfc_get_iterator ();
2040 iter
->var
= gfc_lval_expr_from_sym (idx
);
2041 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2042 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2043 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2044 block
->next
= gfc_get_code (EXEC_DO
);
2045 block
= block
->next
;
2046 block
->ext
.iterator
= iter
;
2047 block
->block
= gfc_get_code (EXEC_DO
);
2049 /* Offset calculation. */
2050 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2051 byte_stride
, rank
, block
->block
,
2055 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2056 + offset, c_ptr), ptr). */
2058 = finalization_scalarizer (array
, ptr
,
2059 gfc_lval_expr_from_sym (offset
),
2061 block
= block
->next
;
2063 /* CALL final_elemental (array). */
2064 block
->next
= gfc_get_code (EXEC_CALL
);
2065 block
= block
->next
;
2066 block
->symtree
= fini_elem
->proc_tree
;
2067 block
->resolved_sym
= fini_elem
->proc_sym
;
2068 block
->ext
.actual
= gfc_get_actual_arglist ();
2069 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2073 /* Finalize and deallocate allocatable components. The same manual
2074 scalarization is used as above. */
2076 if (finalizable_comp
)
2079 gfc_code
*block
= NULL
;
2083 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2084 ptr
->ts
.type
= BT_DERIVED
;
2085 ptr
->ts
.u
.derived
= derived
;
2086 ptr
->attr
.flavor
= FL_VARIABLE
;
2087 ptr
->attr
.pointer
= 1;
2088 ptr
->attr
.artificial
= 1;
2089 gfc_set_sym_referenced (ptr
);
2090 gfc_commit_symbol (ptr
);
2093 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2094 stat
->attr
.flavor
= FL_VARIABLE
;
2095 stat
->attr
.artificial
= 1;
2096 stat
->ts
.type
= BT_INTEGER
;
2097 stat
->ts
.kind
= gfc_default_integer_kind
;
2098 gfc_set_sym_referenced (stat
);
2099 gfc_commit_symbol (stat
);
2102 iter
= gfc_get_iterator ();
2103 iter
->var
= gfc_lval_expr_from_sym (idx
);
2104 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2105 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2106 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2107 last_code
->next
= gfc_get_code (EXEC_DO
);
2108 last_code
= last_code
->next
;
2109 last_code
->ext
.iterator
= iter
;
2110 last_code
->block
= gfc_get_code (EXEC_DO
);
2112 /* Offset calculation. */
2113 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2114 byte_stride
, rank
, last_code
->block
,
2118 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2119 + idx * stride, c_ptr), ptr). */
2120 block
->next
= finalization_scalarizer (array
, ptr
,
2121 gfc_lval_expr_from_sym(offset
),
2123 block
= block
->next
;
2125 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2127 if (comp
== derived
->components
&& derived
->attr
.extension
2128 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2131 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2132 stat
, fini_coarray
, &block
, sub_ns
);
2133 if (!last_code
->block
->next
)
2134 last_code
->block
->next
= block
;
2139 /* Call the finalizer of the ancestor. */
2140 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2142 last_code
->next
= gfc_get_code (EXEC_CALL
);
2143 last_code
= last_code
->next
;
2144 last_code
->symtree
= ancestor_wrapper
->symtree
;
2145 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2147 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2148 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2149 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2150 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2151 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2152 last_code
->ext
.actual
->next
->next
->expr
2153 = gfc_lval_expr_from_sym (fini_coarray
);
2156 gfc_free_expr (rank
);
2157 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2158 vtab_final
->ts
.interface
= final
;
2162 /* Add procedure pointers for all type-bound procedures to a vtab. */
2165 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2167 gfc_symbol
* super_type
;
2169 super_type
= gfc_get_derived_super_type (derived
);
2171 if (super_type
&& (super_type
!= derived
))
2173 /* Make sure that the PPCs appear in the same order as in the parent. */
2174 copy_vtab_proc_comps (super_type
, vtype
);
2175 /* Only needed to get the PPC initializers right. */
2176 add_procs_to_declared_vtab (super_type
, vtype
);
2179 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2180 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2182 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2183 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2187 /* Find or generate the symbol for a derived type's vtab. */
2190 gfc_find_derived_vtab (gfc_symbol
*derived
)
2193 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2194 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2195 gfc_gsymbol
*gsym
= NULL
;
2196 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2198 /* Find the top-level namespace. */
2199 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2203 /* If the type is a class container, use the underlying derived type. */
2204 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2205 derived
= gfc_get_derived_super_type (derived
);
2207 /* Find the gsymbol for the module of use associated derived types. */
2208 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2209 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2210 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2214 /* Work in the gsymbol namespace if the top-level namespace is a module.
2215 This ensures that the vtable is unique, which is required since we use
2216 its address in SELECT TYPE. */
2217 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2218 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2223 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2225 get_unique_hashed_string (tname
, derived
);
2226 sprintf (name
, "__vtab_%s", tname
);
2228 /* Look for the vtab symbol in various namespaces. */
2229 if (gsym
&& gsym
->ns
)
2231 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2236 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2238 gfc_find_symbol (name
, ns
, 0, &vtab
);
2240 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2244 gfc_get_symbol (name
, ns
, &vtab
);
2245 vtab
->ts
.type
= BT_DERIVED
;
2246 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2247 &gfc_current_locus
))
2249 vtab
->attr
.target
= 1;
2250 vtab
->attr
.save
= SAVE_IMPLICIT
;
2251 vtab
->attr
.vtab
= 1;
2252 vtab
->attr
.access
= ACCESS_PUBLIC
;
2253 gfc_set_sym_referenced (vtab
);
2254 sprintf (name
, "__vtype_%s", tname
);
2256 gfc_find_symbol (name
, ns
, 0, &vtype
);
2260 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2263 /* Is this a derived type with recursive allocatable
2265 c
= (derived
->attr
.unlimited_polymorphic
2266 || derived
->attr
.abstract
) ?
2267 NULL
: derived
->components
;
2268 for (; c
; c
= c
->next
)
2269 if (c
->ts
.type
== BT_DERIVED
2270 && c
->ts
.u
.derived
== derived
)
2276 gfc_get_symbol (name
, ns
, &vtype
);
2277 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2278 &gfc_current_locus
))
2280 vtype
->attr
.access
= ACCESS_PUBLIC
;
2281 vtype
->attr
.vtype
= 1;
2282 gfc_set_sym_referenced (vtype
);
2284 /* Add component '_hash'. */
2285 if (!gfc_add_component (vtype
, "_hash", &c
))
2287 c
->ts
.type
= BT_INTEGER
;
2289 c
->attr
.access
= ACCESS_PRIVATE
;
2290 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2291 NULL
, derived
->hash_value
);
2293 /* Add component '_size'. */
2294 if (!gfc_add_component (vtype
, "_size", &c
))
2296 c
->ts
.type
= BT_INTEGER
;
2298 c
->attr
.access
= ACCESS_PRIVATE
;
2299 /* Remember the derived type in ts.u.derived,
2300 so that the correct initializer can be set later on
2301 (in gfc_conv_structure). */
2302 c
->ts
.u
.derived
= derived
;
2303 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2306 /* Add component _extends. */
2307 if (!gfc_add_component (vtype
, "_extends", &c
))
2309 c
->attr
.pointer
= 1;
2310 c
->attr
.access
= ACCESS_PRIVATE
;
2311 if (!derived
->attr
.unlimited_polymorphic
)
2312 parent
= gfc_get_derived_super_type (derived
);
2318 parent_vtab
= gfc_find_derived_vtab (parent
);
2319 c
->ts
.type
= BT_DERIVED
;
2320 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2321 c
->initializer
= gfc_get_expr ();
2322 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2323 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2324 0, &c
->initializer
->symtree
);
2328 c
->ts
.type
= BT_DERIVED
;
2329 c
->ts
.u
.derived
= vtype
;
2330 c
->initializer
= gfc_get_null_expr (NULL
);
2333 if (!derived
->attr
.unlimited_polymorphic
2334 && derived
->components
== NULL
2335 && !derived
->attr
.zero_comp
)
2337 /* At this point an error must have occurred.
2338 Prevent further errors on the vtype components. */
2343 /* Add component _def_init. */
2344 if (!gfc_add_component (vtype
, "_def_init", &c
))
2346 c
->attr
.pointer
= 1;
2347 c
->attr
.artificial
= 1;
2348 c
->attr
.access
= ACCESS_PRIVATE
;
2349 c
->ts
.type
= BT_DERIVED
;
2350 c
->ts
.u
.derived
= derived
;
2351 if (derived
->attr
.unlimited_polymorphic
2352 || derived
->attr
.abstract
)
2353 c
->initializer
= gfc_get_null_expr (NULL
);
2356 /* Construct default initialization variable. */
2357 sprintf (name
, "__def_init_%s", tname
);
2358 gfc_get_symbol (name
, ns
, &def_init
);
2359 def_init
->attr
.target
= 1;
2360 def_init
->attr
.artificial
= 1;
2361 def_init
->attr
.save
= SAVE_IMPLICIT
;
2362 def_init
->attr
.access
= ACCESS_PUBLIC
;
2363 def_init
->attr
.flavor
= FL_VARIABLE
;
2364 gfc_set_sym_referenced (def_init
);
2365 def_init
->ts
.type
= BT_DERIVED
;
2366 def_init
->ts
.u
.derived
= derived
;
2367 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2369 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2372 /* Add component _copy. */
2373 if (!gfc_add_component (vtype
, "_copy", &c
))
2375 c
->attr
.proc_pointer
= 1;
2376 c
->attr
.access
= ACCESS_PRIVATE
;
2377 c
->tb
= XCNEW (gfc_typebound_proc
);
2379 if (derived
->attr
.unlimited_polymorphic
2380 || derived
->attr
.abstract
)
2381 c
->initializer
= gfc_get_null_expr (NULL
);
2384 /* Set up namespace. */
2385 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2386 sub_ns
->sibling
= ns
->contained
;
2387 ns
->contained
= sub_ns
;
2388 sub_ns
->resolved
= 1;
2389 /* Set up procedure symbol. */
2390 sprintf (name
, "__copy_%s", tname
);
2391 gfc_get_symbol (name
, sub_ns
, ©
);
2392 sub_ns
->proc_name
= copy
;
2393 copy
->attr
.flavor
= FL_PROCEDURE
;
2394 copy
->attr
.subroutine
= 1;
2395 copy
->attr
.pure
= 1;
2396 copy
->attr
.artificial
= 1;
2397 copy
->attr
.if_source
= IFSRC_DECL
;
2398 /* This is elemental so that arrays are automatically
2399 treated correctly by the scalarizer. */
2400 copy
->attr
.elemental
= 1;
2401 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2402 copy
->module
= ns
->proc_name
->name
;
2403 gfc_set_sym_referenced (copy
);
2404 /* Set up formal arguments. */
2405 gfc_get_symbol ("src", sub_ns
, &src
);
2406 src
->ts
.type
= BT_DERIVED
;
2407 src
->ts
.u
.derived
= derived
;
2408 src
->attr
.flavor
= FL_VARIABLE
;
2409 src
->attr
.dummy
= 1;
2410 src
->attr
.artificial
= 1;
2411 src
->attr
.intent
= INTENT_IN
;
2412 gfc_set_sym_referenced (src
);
2413 copy
->formal
= gfc_get_formal_arglist ();
2414 copy
->formal
->sym
= src
;
2415 gfc_get_symbol ("dst", sub_ns
, &dst
);
2416 dst
->ts
.type
= BT_DERIVED
;
2417 dst
->ts
.u
.derived
= derived
;
2418 dst
->attr
.flavor
= FL_VARIABLE
;
2419 dst
->attr
.dummy
= 1;
2420 dst
->attr
.artificial
= 1;
2421 dst
->attr
.intent
= INTENT_INOUT
;
2422 gfc_set_sym_referenced (dst
);
2423 copy
->formal
->next
= gfc_get_formal_arglist ();
2424 copy
->formal
->next
->sym
= dst
;
2426 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2427 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2428 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2429 /* Set initializer. */
2430 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2431 c
->ts
.interface
= copy
;
2434 /* Add component _final, which contains a procedure pointer to
2435 a wrapper which handles both the freeing of allocatable
2436 components and the calls to finalization subroutines.
2437 Note: The actual wrapper function can only be generated
2438 at resolution time. */
2439 if (!gfc_add_component (vtype
, "_final", &c
))
2441 c
->attr
.proc_pointer
= 1;
2442 c
->attr
.access
= ACCESS_PRIVATE
;
2443 c
->tb
= XCNEW (gfc_typebound_proc
);
2445 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2447 /* Add component _deallocate. */
2448 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2450 c
->attr
.proc_pointer
= 1;
2451 c
->attr
.access
= ACCESS_PRIVATE
;
2452 c
->tb
= XCNEW (gfc_typebound_proc
);
2454 if (derived
->attr
.unlimited_polymorphic
2455 || derived
->attr
.abstract
2457 c
->initializer
= gfc_get_null_expr (NULL
);
2460 /* Set up namespace. */
2461 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2463 sub_ns
->sibling
= ns
->contained
;
2464 ns
->contained
= sub_ns
;
2465 sub_ns
->resolved
= 1;
2466 /* Set up procedure symbol. */
2467 sprintf (name
, "__deallocate_%s", tname
);
2468 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2469 sub_ns
->proc_name
= dealloc
;
2470 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2471 dealloc
->attr
.subroutine
= 1;
2472 dealloc
->attr
.pure
= 1;
2473 dealloc
->attr
.artificial
= 1;
2474 dealloc
->attr
.if_source
= IFSRC_DECL
;
2476 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2477 dealloc
->module
= ns
->proc_name
->name
;
2478 gfc_set_sym_referenced (dealloc
);
2479 /* Set up formal argument. */
2480 gfc_get_symbol ("arg", sub_ns
, &arg
);
2481 arg
->ts
.type
= BT_DERIVED
;
2482 arg
->ts
.u
.derived
= derived
;
2483 arg
->attr
.flavor
= FL_VARIABLE
;
2484 arg
->attr
.dummy
= 1;
2485 arg
->attr
.artificial
= 1;
2486 arg
->attr
.intent
= INTENT_INOUT
;
2487 arg
->attr
.dimension
= 1;
2488 arg
->attr
.allocatable
= 1;
2489 arg
->as
= gfc_get_array_spec();
2490 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2492 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2494 gfc_set_sym_referenced (arg
);
2495 dealloc
->formal
= gfc_get_formal_arglist ();
2496 dealloc
->formal
->sym
= arg
;
2498 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2499 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2500 sub_ns
->code
->ext
.alloc
.list
->expr
2501 = gfc_lval_expr_from_sym (arg
);
2502 /* Set initializer. */
2503 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2504 c
->ts
.interface
= dealloc
;
2507 /* Add procedure pointers for type-bound procedures. */
2508 if (!derived
->attr
.unlimited_polymorphic
)
2509 add_procs_to_declared_vtab (derived
, vtype
);
2513 vtab
->ts
.u
.derived
= vtype
;
2514 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2521 /* It is unexpected to have some symbols added at resolution or code
2522 generation time. We commit the changes in order to keep a clean state. */
2525 gfc_commit_symbol (vtab
);
2527 gfc_commit_symbol (vtype
);
2529 gfc_commit_symbol (def_init
);
2531 gfc_commit_symbol (copy
);
2533 gfc_commit_symbol (src
);
2535 gfc_commit_symbol (dst
);
2537 gfc_commit_symbol (dealloc
);
2539 gfc_commit_symbol (arg
);
2542 gfc_undo_symbols ();
2548 /* Check if a derived type is finalizable. That is the case if it
2549 (1) has a FINAL subroutine or
2550 (2) has a nonpointer nonallocatable component of finalizable type.
2551 If it is finalizable, return an expression containing the
2552 finalization wrapper. */
2555 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2560 /* (1) Check for FINAL subroutines. */
2561 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2564 /* (2) Check for components of finalizable type. */
2565 for (c
= derived
->components
; c
; c
= c
->next
)
2566 if (c
->ts
.type
== BT_DERIVED
2567 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2568 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2574 /* Make sure vtab is generated. */
2575 vtab
= gfc_find_derived_vtab (derived
);
2578 /* Return finalizer expression. */
2579 gfc_component
*final
;
2580 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2581 gcc_assert (strcmp (final
->name
, "_final") == 0);
2582 gcc_assert (final
->initializer
2583 && final
->initializer
->expr_type
!= EXPR_NULL
);
2584 *final_expr
= final
->initializer
;
2590 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2591 needed to support unlimited polymorphism. */
2594 find_intrinsic_vtab (gfc_typespec
*ts
)
2597 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2598 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2600 /* Find the top-level namespace. */
2601 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2607 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2609 /* Encode all types as TYPENAME_KIND_ including especially character
2610 arrays, whose length is now consistently stored in the _len component
2611 of the class-variable. */
2612 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2613 sprintf (name
, "__vtab_%s", tname
);
2615 /* Look for the vtab symbol in the top-level namespace only. */
2616 gfc_find_symbol (name
, ns
, 0, &vtab
);
2620 gfc_get_symbol (name
, ns
, &vtab
);
2621 vtab
->ts
.type
= BT_DERIVED
;
2622 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2623 &gfc_current_locus
))
2625 vtab
->attr
.target
= 1;
2626 vtab
->attr
.save
= SAVE_IMPLICIT
;
2627 vtab
->attr
.vtab
= 1;
2628 vtab
->attr
.access
= ACCESS_PUBLIC
;
2629 gfc_set_sym_referenced (vtab
);
2630 sprintf (name
, "__vtype_%s", tname
);
2632 gfc_find_symbol (name
, ns
, 0, &vtype
);
2637 gfc_namespace
*sub_ns
;
2638 gfc_namespace
*contained
;
2641 gfc_get_symbol (name
, ns
, &vtype
);
2642 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2643 &gfc_current_locus
))
2645 vtype
->attr
.access
= ACCESS_PUBLIC
;
2646 vtype
->attr
.vtype
= 1;
2647 gfc_set_sym_referenced (vtype
);
2649 /* Add component '_hash'. */
2650 if (!gfc_add_component (vtype
, "_hash", &c
))
2652 c
->ts
.type
= BT_INTEGER
;
2654 c
->attr
.access
= ACCESS_PRIVATE
;
2655 hash
= gfc_intrinsic_hash_value (ts
);
2656 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2659 /* Add component '_size'. */
2660 if (!gfc_add_component (vtype
, "_size", &c
))
2662 c
->ts
.type
= BT_INTEGER
;
2664 c
->attr
.access
= ACCESS_PRIVATE
;
2666 /* Build a minimal expression to make use of
2667 target-memory.c/gfc_element_size for 'size'. Special handling
2668 for character arrays, that are not constant sized: to support
2669 len (str) * kind, only the kind information is stored in the
2671 e
= gfc_get_expr ();
2673 e
->expr_type
= EXPR_VARIABLE
;
2674 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2676 ts
->type
== BT_CHARACTER
2678 : (int)gfc_element_size (e
));
2681 /* Add component _extends. */
2682 if (!gfc_add_component (vtype
, "_extends", &c
))
2684 c
->attr
.pointer
= 1;
2685 c
->attr
.access
= ACCESS_PRIVATE
;
2686 c
->ts
.type
= BT_VOID
;
2687 c
->initializer
= gfc_get_null_expr (NULL
);
2689 /* Add component _def_init. */
2690 if (!gfc_add_component (vtype
, "_def_init", &c
))
2692 c
->attr
.pointer
= 1;
2693 c
->attr
.access
= ACCESS_PRIVATE
;
2694 c
->ts
.type
= BT_VOID
;
2695 c
->initializer
= gfc_get_null_expr (NULL
);
2697 /* Add component _copy. */
2698 if (!gfc_add_component (vtype
, "_copy", &c
))
2700 c
->attr
.proc_pointer
= 1;
2701 c
->attr
.access
= ACCESS_PRIVATE
;
2702 c
->tb
= XCNEW (gfc_typebound_proc
);
2705 if (ts
->type
!= BT_CHARACTER
)
2706 sprintf (name
, "__copy_%s", tname
);
2709 /* __copy is always the same for characters.
2710 Check to see if copy function already exists. */
2711 sprintf (name
, "__copy_character_%d", ts
->kind
);
2712 contained
= ns
->contained
;
2713 for (; contained
; contained
= contained
->sibling
)
2714 if (contained
->proc_name
2715 && strcmp (name
, contained
->proc_name
->name
) == 0)
2717 copy
= contained
->proc_name
;
2722 /* Set up namespace. */
2723 sub_ns
= gfc_get_namespace (ns
, 0);
2724 sub_ns
->sibling
= ns
->contained
;
2725 ns
->contained
= sub_ns
;
2726 sub_ns
->resolved
= 1;
2727 /* Set up procedure symbol. */
2728 gfc_get_symbol (name
, sub_ns
, ©
);
2729 sub_ns
->proc_name
= copy
;
2730 copy
->attr
.flavor
= FL_PROCEDURE
;
2731 copy
->attr
.subroutine
= 1;
2732 copy
->attr
.pure
= 1;
2733 copy
->attr
.if_source
= IFSRC_DECL
;
2734 /* This is elemental so that arrays are automatically
2735 treated correctly by the scalarizer. */
2736 copy
->attr
.elemental
= 1;
2737 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2738 copy
->module
= ns
->proc_name
->name
;
2739 gfc_set_sym_referenced (copy
);
2740 /* Set up formal arguments. */
2741 gfc_get_symbol ("src", sub_ns
, &src
);
2742 src
->ts
.type
= ts
->type
;
2743 src
->ts
.kind
= ts
->kind
;
2744 src
->attr
.flavor
= FL_VARIABLE
;
2745 src
->attr
.dummy
= 1;
2746 src
->attr
.intent
= INTENT_IN
;
2747 gfc_set_sym_referenced (src
);
2748 copy
->formal
= gfc_get_formal_arglist ();
2749 copy
->formal
->sym
= src
;
2750 gfc_get_symbol ("dst", sub_ns
, &dst
);
2751 dst
->ts
.type
= ts
->type
;
2752 dst
->ts
.kind
= ts
->kind
;
2753 dst
->attr
.flavor
= FL_VARIABLE
;
2754 dst
->attr
.dummy
= 1;
2755 dst
->attr
.intent
= INTENT_INOUT
;
2756 gfc_set_sym_referenced (dst
);
2757 copy
->formal
->next
= gfc_get_formal_arglist ();
2758 copy
->formal
->next
->sym
= dst
;
2760 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2761 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2762 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2764 /* Set initializer. */
2765 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2766 c
->ts
.interface
= copy
;
2768 /* Add component _final. */
2769 if (!gfc_add_component (vtype
, "_final", &c
))
2771 c
->attr
.proc_pointer
= 1;
2772 c
->attr
.access
= ACCESS_PRIVATE
;
2773 c
->tb
= XCNEW (gfc_typebound_proc
);
2775 c
->initializer
= gfc_get_null_expr (NULL
);
2777 vtab
->ts
.u
.derived
= vtype
;
2778 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2785 /* It is unexpected to have some symbols added at resolution or code
2786 generation time. We commit the changes in order to keep a clean state. */
2789 gfc_commit_symbol (vtab
);
2791 gfc_commit_symbol (vtype
);
2793 gfc_commit_symbol (copy
);
2795 gfc_commit_symbol (src
);
2797 gfc_commit_symbol (dst
);
2800 gfc_undo_symbols ();
2806 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2809 gfc_find_vtab (gfc_typespec
*ts
)
2816 return gfc_find_derived_vtab (ts
->u
.derived
);
2818 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2820 return find_intrinsic_vtab (ts
);
2825 /* General worker function to find either a type-bound procedure or a
2826 type-bound user operator. */
2829 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2830 const char* name
, bool noaccess
, bool uop
,
2836 /* Set default to failure. */
2840 if (derived
->f2k_derived
)
2841 /* Set correct symbol-root. */
2842 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2843 : derived
->f2k_derived
->tb_sym_root
);
2847 /* Try to find it in the current type's namespace. */
2848 res
= gfc_find_symtree (root
, name
);
2849 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2855 if (!noaccess
&& derived
->attr
.use_assoc
2856 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2859 gfc_error ("%qs of %qs is PRIVATE at %L",
2860 name
, derived
->name
, where
);
2868 /* Otherwise, recurse on parent type if derived is an extension. */
2869 if (derived
->attr
.extension
)
2871 gfc_symbol
* super_type
;
2872 super_type
= gfc_get_derived_super_type (derived
);
2873 gcc_assert (super_type
);
2875 return find_typebound_proc_uop (super_type
, t
, name
,
2876 noaccess
, uop
, where
);
2879 /* Nothing found. */
2884 /* Find a type-bound procedure or user operator by name for a derived-type
2885 (looking recursively through the super-types). */
2888 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2889 const char* name
, bool noaccess
, locus
* where
)
2891 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2895 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2896 const char* name
, bool noaccess
, locus
* where
)
2898 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2902 /* Find a type-bound intrinsic operator looking recursively through the
2903 super-type hierarchy. */
2906 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2907 gfc_intrinsic_op op
, bool noaccess
,
2910 gfc_typebound_proc
* res
;
2912 /* Set default to failure. */
2916 /* Try to find it in the current type's namespace. */
2917 if (derived
->f2k_derived
)
2918 res
= derived
->f2k_derived
->tb_op
[op
];
2923 if (res
&& !res
->error
)
2929 if (!noaccess
&& derived
->attr
.use_assoc
2930 && res
->access
== ACCESS_PRIVATE
)
2933 gfc_error ("%qs of %qs is PRIVATE at %L",
2934 gfc_op2string (op
), derived
->name
, where
);
2942 /* Otherwise, recurse on parent type if derived is an extension. */
2943 if (derived
->attr
.extension
)
2945 gfc_symbol
* super_type
;
2946 super_type
= gfc_get_derived_super_type (derived
);
2947 gcc_assert (super_type
);
2949 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2953 /* Nothing found. */
2958 /* Get a typebound-procedure symtree or create and insert it if not yet
2959 present. This is like a very simplified version of gfc_get_sym_tree for
2960 tbp-symtrees rather than regular ones. */
2963 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2965 gfc_symtree
*result
;
2967 result
= gfc_find_symtree (*root
, name
);
2970 result
= gfc_new_symtree (root
, name
);
2971 gcc_assert (result
);
2972 result
->n
.tb
= NULL
;