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
);
1353 block
->block
= gfc_get_code (EXEC_IF
);
1354 block
= block
->block
;
1356 /* BLOCK ... END BLOCK. */
1357 block
->next
= gfc_get_code (EXEC_BLOCK
);
1358 block
= block
->next
;
1360 ns
= gfc_build_block_ns (sub_ns
);
1361 block
->ext
.block
.ns
= ns
;
1362 block
->ext
.block
.assoc
= NULL
;
1364 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1365 ptr2
->ts
.type
= BT_DERIVED
;
1366 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1367 ptr2
->attr
.flavor
= FL_VARIABLE
;
1368 ptr2
->attr
.pointer
= 1;
1369 ptr2
->attr
.artificial
= 1;
1370 gfc_set_sym_referenced (ptr2
);
1371 gfc_commit_symbol (ptr2
);
1373 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1374 tmp_array
->ts
.type
= BT_DERIVED
;
1375 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1376 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1377 tmp_array
->attr
.dimension
= 1;
1378 tmp_array
->attr
.artificial
= 1;
1379 tmp_array
->as
= gfc_get_array_spec();
1380 tmp_array
->attr
.intent
= INTENT_INOUT
;
1381 tmp_array
->as
->type
= AS_EXPLICIT
;
1382 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1384 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1386 gfc_expr
*shape_expr
;
1387 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1389 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1391 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1392 gfc_current_locus
, 3,
1393 gfc_lval_expr_from_sym (array
),
1394 gfc_get_int_expr (gfc_default_integer_kind
,
1396 gfc_get_int_expr (gfc_default_integer_kind
,
1398 gfc_index_integer_kind
));
1399 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1400 tmp_array
->as
->upper
[i
] = shape_expr
;
1402 gfc_set_sym_referenced (tmp_array
);
1403 gfc_commit_symbol (tmp_array
);
1406 iter
= gfc_get_iterator ();
1407 iter
->var
= gfc_lval_expr_from_sym (idx
);
1408 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1409 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1410 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1412 block
= gfc_get_code (EXEC_DO
);
1414 block
->ext
.iterator
= iter
;
1415 block
->block
= gfc_get_code (EXEC_DO
);
1417 /* Offset calculation for the new array: idx * size of type (in bytes). */
1418 offset2
= gfc_get_expr ();
1419 offset2
->expr_type
= EXPR_OP
;
1420 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1421 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1422 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1423 offset2
->ts
= byte_stride
->ts
;
1425 /* Offset calculation of "array". */
1426 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1427 byte_stride
, rank
, block
->block
, sub_ns
);
1430 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1431 + idx * stride, c_ptr), ptr). */
1432 block2
->next
= finalization_scalarizer (array
, ptr
,
1433 gfc_lval_expr_from_sym (offset
),
1435 block2
= block2
->next
;
1436 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1437 block2
= block2
->next
;
1440 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1441 block2
= block2
->next
;
1442 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1443 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1445 /* Call now the user's final subroutine. */
1446 block
->next
= gfc_get_code (EXEC_CALL
);
1447 block
= block
->next
;
1448 block
->symtree
= fini
->proc_tree
;
1449 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1450 block
->ext
.actual
= gfc_get_actual_arglist ();
1451 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1453 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1459 iter
= gfc_get_iterator ();
1460 iter
->var
= gfc_lval_expr_from_sym (idx
);
1461 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1462 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1463 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1465 block
->next
= gfc_get_code (EXEC_DO
);
1466 block
= block
->next
;
1467 block
->ext
.iterator
= iter
;
1468 block
->block
= gfc_get_code (EXEC_DO
);
1470 /* Offset calculation of "array". */
1471 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1472 byte_stride
, rank
, block
->block
, sub_ns
);
1475 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1476 + offset, c_ptr), ptr). */
1477 block2
->next
= finalization_scalarizer (array
, ptr
,
1478 gfc_lval_expr_from_sym (offset
),
1480 block2
= block2
->next
;
1481 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1482 gfc_copy_expr (offset2
), sub_ns
);
1483 block2
= block2
->next
;
1486 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1487 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1488 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1492 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1493 derived type "derived". The function first calls the approriate FINAL
1494 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1495 components (but not the inherited ones). Last, it calls the wrapper
1496 subroutine of the parent. The generated wrapper procedure takes as argument
1497 an assumed-rank array.
1498 If neither allocatable components nor FINAL subroutines exists, the vtab
1499 will contain a NULL pointer.
1500 The generated function has the form
1501 _final(assumed-rank array, stride, skip_corarray)
1502 where the array has to be contiguous (except of the lowest dimension). The
1503 stride (in bytes) is used to allow different sizes for ancestor types by
1504 skipping over the additionally added components in the scalarizer. If
1505 "fini_coarray" is false, coarray components are not finalized to allow for
1506 the correct semantic with intrinsic assignment. */
1509 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1510 const char *tname
, gfc_component
*vtab_final
)
1512 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1513 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1514 gfc_component
*comp
;
1515 gfc_namespace
*sub_ns
;
1516 gfc_code
*last_code
, *block
;
1517 char name
[GFC_MAX_SYMBOL_LEN
+1];
1518 bool finalizable_comp
= false;
1519 bool expr_null_wrapper
= false;
1520 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1523 if (derived
->attr
.unlimited_polymorphic
)
1525 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1529 /* Search for the ancestor's finalizers. */
1530 if (derived
->attr
.extension
&& derived
->components
1531 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1532 || has_finalizer_component (derived
)))
1535 gfc_component
*comp
;
1537 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1538 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1539 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1541 ancestor_wrapper
= comp
->initializer
;
1546 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1547 components: Return a NULL() expression; we defer this a bit to have have
1548 an interface declaration. */
1549 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1550 && !derived
->attr
.alloc_comp
1551 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1552 && !has_finalizer_component (derived
))
1553 expr_null_wrapper
= true;
1555 /* Check whether there are new allocatable components. */
1556 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1558 if (comp
== derived
->components
&& derived
->attr
.extension
1559 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1562 finalizable_comp
|= comp_is_finalizable (comp
);
1565 /* If there is no new finalizer and no new allocatable, return with
1566 an expr to the ancestor's one. */
1567 if (!expr_null_wrapper
&& !finalizable_comp
1568 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1570 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1571 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1572 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1573 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1577 /* We now create a wrapper, which does the following:
1578 1. Call the suitable finalization subroutine for this type
1579 2. Loop over all noninherited allocatable components and noninherited
1580 components with allocatable components and DEALLOCATE those; this will
1581 take care of finalizers, coarray deregistering and allocatable
1583 3. Call the ancestor's finalizer. */
1585 /* Declare the wrapper function; it takes an assumed-rank array
1586 and a VALUE logical as arguments. */
1588 /* Set up the namespace. */
1589 sub_ns
= gfc_get_namespace (ns
, 0);
1590 sub_ns
->sibling
= ns
->contained
;
1591 if (!expr_null_wrapper
)
1592 ns
->contained
= sub_ns
;
1593 sub_ns
->resolved
= 1;
1595 /* Set up the procedure symbol. */
1596 sprintf (name
, "__final_%s", tname
);
1597 gfc_get_symbol (name
, sub_ns
, &final
);
1598 sub_ns
->proc_name
= final
;
1599 final
->attr
.flavor
= FL_PROCEDURE
;
1600 final
->attr
.function
= 1;
1601 final
->attr
.pure
= 0;
1602 final
->result
= final
;
1603 final
->ts
.type
= BT_INTEGER
;
1605 final
->attr
.artificial
= 1;
1606 final
->attr
.always_explicit
= 1;
1607 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1608 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1609 final
->module
= ns
->proc_name
->name
;
1610 gfc_set_sym_referenced (final
);
1611 gfc_commit_symbol (final
);
1613 /* Set up formal argument. */
1614 gfc_get_symbol ("array", sub_ns
, &array
);
1615 array
->ts
.type
= BT_DERIVED
;
1616 array
->ts
.u
.derived
= derived
;
1617 array
->attr
.flavor
= FL_VARIABLE
;
1618 array
->attr
.dummy
= 1;
1619 array
->attr
.contiguous
= 1;
1620 array
->attr
.dimension
= 1;
1621 array
->attr
.artificial
= 1;
1622 array
->as
= gfc_get_array_spec();
1623 array
->as
->type
= AS_ASSUMED_RANK
;
1624 array
->as
->rank
= -1;
1625 array
->attr
.intent
= INTENT_INOUT
;
1626 gfc_set_sym_referenced (array
);
1627 final
->formal
= gfc_get_formal_arglist ();
1628 final
->formal
->sym
= array
;
1629 gfc_commit_symbol (array
);
1631 /* Set up formal argument. */
1632 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1633 byte_stride
->ts
.type
= BT_INTEGER
;
1634 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1635 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1636 byte_stride
->attr
.dummy
= 1;
1637 byte_stride
->attr
.value
= 1;
1638 byte_stride
->attr
.artificial
= 1;
1639 gfc_set_sym_referenced (byte_stride
);
1640 final
->formal
->next
= gfc_get_formal_arglist ();
1641 final
->formal
->next
->sym
= byte_stride
;
1642 gfc_commit_symbol (byte_stride
);
1644 /* Set up formal argument. */
1645 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1646 fini_coarray
->ts
.type
= BT_LOGICAL
;
1647 fini_coarray
->ts
.kind
= 1;
1648 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1649 fini_coarray
->attr
.dummy
= 1;
1650 fini_coarray
->attr
.value
= 1;
1651 fini_coarray
->attr
.artificial
= 1;
1652 gfc_set_sym_referenced (fini_coarray
);
1653 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1654 final
->formal
->next
->next
->sym
= fini_coarray
;
1655 gfc_commit_symbol (fini_coarray
);
1657 /* Return with a NULL() expression but with an interface which has
1658 the formal arguments. */
1659 if (expr_null_wrapper
)
1661 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1662 vtab_final
->ts
.interface
= final
;
1666 /* Local variables. */
1668 gfc_get_symbol ("idx", sub_ns
, &idx
);
1669 idx
->ts
.type
= BT_INTEGER
;
1670 idx
->ts
.kind
= gfc_index_integer_kind
;
1671 idx
->attr
.flavor
= FL_VARIABLE
;
1672 idx
->attr
.artificial
= 1;
1673 gfc_set_sym_referenced (idx
);
1674 gfc_commit_symbol (idx
);
1676 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1677 idx2
->ts
.type
= BT_INTEGER
;
1678 idx2
->ts
.kind
= gfc_index_integer_kind
;
1679 idx2
->attr
.flavor
= FL_VARIABLE
;
1680 idx2
->attr
.artificial
= 1;
1681 gfc_set_sym_referenced (idx2
);
1682 gfc_commit_symbol (idx2
);
1684 gfc_get_symbol ("offset", sub_ns
, &offset
);
1685 offset
->ts
.type
= BT_INTEGER
;
1686 offset
->ts
.kind
= gfc_index_integer_kind
;
1687 offset
->attr
.flavor
= FL_VARIABLE
;
1688 offset
->attr
.artificial
= 1;
1689 gfc_set_sym_referenced (offset
);
1690 gfc_commit_symbol (offset
);
1692 /* Create RANK expression. */
1693 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1694 gfc_current_locus
, 1,
1695 gfc_lval_expr_from_sym (array
));
1696 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1697 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1699 /* Create is_contiguous variable. */
1700 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1701 is_contiguous
->ts
.type
= BT_LOGICAL
;
1702 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1703 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1704 is_contiguous
->attr
.artificial
= 1;
1705 gfc_set_sym_referenced (is_contiguous
);
1706 gfc_commit_symbol (is_contiguous
);
1708 /* Create "sizes(0..rank)" variable, which contains the multiplied
1709 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1710 sizes(2) = sizes(1) * extent(dim=2) etc. */
1711 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1712 sizes
->ts
.type
= BT_INTEGER
;
1713 sizes
->ts
.kind
= gfc_index_integer_kind
;
1714 sizes
->attr
.flavor
= FL_VARIABLE
;
1715 sizes
->attr
.dimension
= 1;
1716 sizes
->attr
.artificial
= 1;
1717 sizes
->as
= gfc_get_array_spec();
1718 sizes
->attr
.intent
= INTENT_INOUT
;
1719 sizes
->as
->type
= AS_EXPLICIT
;
1720 sizes
->as
->rank
= 1;
1721 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1722 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1723 gfc_set_sym_referenced (sizes
);
1724 gfc_commit_symbol (sizes
);
1726 /* Create "strides(1..rank)" variable, which contains the strides per
1728 gfc_get_symbol ("strides", sub_ns
, &strides
);
1729 strides
->ts
.type
= BT_INTEGER
;
1730 strides
->ts
.kind
= gfc_index_integer_kind
;
1731 strides
->attr
.flavor
= FL_VARIABLE
;
1732 strides
->attr
.dimension
= 1;
1733 strides
->attr
.artificial
= 1;
1734 strides
->as
= gfc_get_array_spec();
1735 strides
->attr
.intent
= INTENT_INOUT
;
1736 strides
->as
->type
= AS_EXPLICIT
;
1737 strides
->as
->rank
= 1;
1738 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1739 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1740 gfc_set_sym_referenced (strides
);
1741 gfc_commit_symbol (strides
);
1744 /* Set return value to 0. */
1745 last_code
= gfc_get_code (EXEC_ASSIGN
);
1746 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1747 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1748 sub_ns
->code
= last_code
;
1750 /* Set: is_contiguous = .true. */
1751 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1752 last_code
= last_code
->next
;
1753 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1754 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1755 &gfc_current_locus
, true);
1757 /* Set: sizes(0) = 1. */
1758 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1759 last_code
= last_code
->next
;
1760 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1761 last_code
->expr1
->ref
= gfc_get_ref ();
1762 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1763 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1764 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1765 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1766 last_code
->expr1
->ref
->u
.ar
.start
[0]
1767 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1768 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1769 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1773 strides(idx) = _F._stride (array, dim=idx)
1774 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1775 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1779 iter
= gfc_get_iterator ();
1780 iter
->var
= gfc_lval_expr_from_sym (idx
);
1781 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1782 iter
->end
= gfc_copy_expr (rank
);
1783 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1784 last_code
->next
= gfc_get_code (EXEC_DO
);
1785 last_code
= last_code
->next
;
1786 last_code
->ext
.iterator
= iter
;
1787 last_code
->block
= gfc_get_code (EXEC_DO
);
1789 /* strides(idx) = _F._stride(array,dim=idx). */
1790 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1791 block
= last_code
->block
->next
;
1793 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1794 block
->expr1
->ref
= gfc_get_ref ();
1795 block
->expr1
->ref
->type
= REF_ARRAY
;
1796 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1797 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1798 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1799 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1800 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1802 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1803 gfc_current_locus
, 2,
1804 gfc_lval_expr_from_sym (array
),
1805 gfc_lval_expr_from_sym (idx
));
1807 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1808 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1809 block
= block
->next
;
1811 /* sizes(idx) = ... */
1812 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1813 block
->expr1
->ref
= gfc_get_ref ();
1814 block
->expr1
->ref
->type
= REF_ARRAY
;
1815 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1816 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1817 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1818 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1819 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1821 block
->expr2
= gfc_get_expr ();
1822 block
->expr2
->expr_type
= EXPR_OP
;
1823 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1826 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1827 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1828 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1829 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1830 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1831 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1832 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1833 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1834 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1835 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1836 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1837 = gfc_lval_expr_from_sym (idx
);
1838 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1839 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1840 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1841 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1843 /* size(array, dim=idx, kind=index_kind). */
1844 block
->expr2
->value
.op
.op2
1845 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1846 gfc_current_locus
, 3,
1847 gfc_lval_expr_from_sym (array
),
1848 gfc_lval_expr_from_sym (idx
),
1849 gfc_get_int_expr (gfc_index_integer_kind
,
1851 gfc_index_integer_kind
));
1852 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1853 block
->expr2
->ts
= idx
->ts
;
1855 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1856 block
->next
= gfc_get_code (EXEC_IF
);
1857 block
= block
->next
;
1859 block
->block
= gfc_get_code (EXEC_IF
);
1860 block
= block
->block
;
1862 /* if condition: strides(idx) /= sizes(idx-1). */
1863 block
->expr1
= gfc_get_expr ();
1864 block
->expr1
->ts
.type
= BT_LOGICAL
;
1865 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1866 block
->expr1
->expr_type
= EXPR_OP
;
1867 block
->expr1
->where
= gfc_current_locus
;
1868 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1870 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1871 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1872 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1873 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1874 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1875 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1876 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1877 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1879 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1880 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1881 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1882 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1883 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1884 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1885 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1886 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1887 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1888 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1889 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1890 = gfc_lval_expr_from_sym (idx
);
1891 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1892 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1893 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1894 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1896 /* if body: is_contiguous = .false. */
1897 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1898 block
= block
->next
;
1899 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1900 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1901 &gfc_current_locus
, false);
1903 /* Obtain the size (number of elements) of "array" MINUS ONE,
1904 which is used in the scalarization. */
1905 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1906 nelem
->ts
.type
= BT_INTEGER
;
1907 nelem
->ts
.kind
= gfc_index_integer_kind
;
1908 nelem
->attr
.flavor
= FL_VARIABLE
;
1909 nelem
->attr
.artificial
= 1;
1910 gfc_set_sym_referenced (nelem
);
1911 gfc_commit_symbol (nelem
);
1913 /* nelem = sizes (rank) - 1. */
1914 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1915 last_code
= last_code
->next
;
1917 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1919 last_code
->expr2
= gfc_get_expr ();
1920 last_code
->expr2
->expr_type
= EXPR_OP
;
1921 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1922 last_code
->expr2
->value
.op
.op2
1923 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1924 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1926 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1927 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1928 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1929 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1930 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1931 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1932 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1933 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1935 /* Call final subroutines. We now generate code like:
1937 integer, pointer :: ptr
1939 integer(c_intptr_t) :: i, addr
1941 select case (rank (array))
1943 ! If needed, the array is packed
1944 call final_rank3 (array)
1946 do i = 0, size (array)-1
1947 addr = transfer (c_loc (array), addr) + i * stride
1948 call c_f_pointer (transfer (addr, cptr), ptr)
1949 call elemental_final (ptr)
1953 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1955 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1957 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1958 ptr
->ts
.type
= BT_DERIVED
;
1959 ptr
->ts
.u
.derived
= derived
;
1960 ptr
->attr
.flavor
= FL_VARIABLE
;
1961 ptr
->attr
.pointer
= 1;
1962 ptr
->attr
.artificial
= 1;
1963 gfc_set_sym_referenced (ptr
);
1964 gfc_commit_symbol (ptr
);
1966 /* SELECT CASE (RANK (array)). */
1967 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1968 last_code
= last_code
->next
;
1969 last_code
->expr1
= gfc_copy_expr (rank
);
1972 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1974 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1975 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1981 /* CASE (fini_rank). */
1984 block
->block
= gfc_get_code (EXEC_SELECT
);
1985 block
= block
->block
;
1989 block
= gfc_get_code (EXEC_SELECT
);
1990 last_code
->block
= block
;
1992 block
->ext
.block
.case_list
= gfc_get_case ();
1993 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1994 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1995 block
->ext
.block
.case_list
->low
1996 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1997 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1999 block
->ext
.block
.case_list
->low
2000 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2001 block
->ext
.block
.case_list
->high
2002 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2004 /* CALL fini_rank (array) - possibly with packing. */
2005 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2006 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2007 idx
, ptr
, nelem
, strides
,
2008 sizes
, idx2
, offset
, is_contiguous
,
2012 block
->next
= gfc_get_code (EXEC_CALL
);
2013 block
->next
->symtree
= fini
->proc_tree
;
2014 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2015 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2016 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2020 /* Elemental call - scalarized. */
2026 block
->block
= gfc_get_code (EXEC_SELECT
);
2027 block
= block
->block
;
2031 block
= gfc_get_code (EXEC_SELECT
);
2032 last_code
->block
= block
;
2034 block
->ext
.block
.case_list
= gfc_get_case ();
2037 iter
= gfc_get_iterator ();
2038 iter
->var
= gfc_lval_expr_from_sym (idx
);
2039 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2040 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2041 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2042 block
->next
= gfc_get_code (EXEC_DO
);
2043 block
= block
->next
;
2044 block
->ext
.iterator
= iter
;
2045 block
->block
= gfc_get_code (EXEC_DO
);
2047 /* Offset calculation. */
2048 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2049 byte_stride
, rank
, block
->block
,
2053 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2054 + offset, c_ptr), ptr). */
2056 = finalization_scalarizer (array
, ptr
,
2057 gfc_lval_expr_from_sym (offset
),
2059 block
= block
->next
;
2061 /* CALL final_elemental (array). */
2062 block
->next
= gfc_get_code (EXEC_CALL
);
2063 block
= block
->next
;
2064 block
->symtree
= fini_elem
->proc_tree
;
2065 block
->resolved_sym
= fini_elem
->proc_sym
;
2066 block
->ext
.actual
= gfc_get_actual_arglist ();
2067 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2071 /* Finalize and deallocate allocatable components. The same manual
2072 scalarization is used as above. */
2074 if (finalizable_comp
)
2077 gfc_code
*block
= NULL
;
2081 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2082 ptr
->ts
.type
= BT_DERIVED
;
2083 ptr
->ts
.u
.derived
= derived
;
2084 ptr
->attr
.flavor
= FL_VARIABLE
;
2085 ptr
->attr
.pointer
= 1;
2086 ptr
->attr
.artificial
= 1;
2087 gfc_set_sym_referenced (ptr
);
2088 gfc_commit_symbol (ptr
);
2091 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2092 stat
->attr
.flavor
= FL_VARIABLE
;
2093 stat
->attr
.artificial
= 1;
2094 stat
->ts
.type
= BT_INTEGER
;
2095 stat
->ts
.kind
= gfc_default_integer_kind
;
2096 gfc_set_sym_referenced (stat
);
2097 gfc_commit_symbol (stat
);
2100 iter
= gfc_get_iterator ();
2101 iter
->var
= gfc_lval_expr_from_sym (idx
);
2102 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2103 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2104 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2105 last_code
->next
= gfc_get_code (EXEC_DO
);
2106 last_code
= last_code
->next
;
2107 last_code
->ext
.iterator
= iter
;
2108 last_code
->block
= gfc_get_code (EXEC_DO
);
2110 /* Offset calculation. */
2111 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2112 byte_stride
, rank
, last_code
->block
,
2116 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2117 + idx * stride, c_ptr), ptr). */
2118 block
->next
= finalization_scalarizer (array
, ptr
,
2119 gfc_lval_expr_from_sym(offset
),
2121 block
= block
->next
;
2123 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2125 if (comp
== derived
->components
&& derived
->attr
.extension
2126 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2129 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2130 stat
, fini_coarray
, &block
, sub_ns
);
2131 if (!last_code
->block
->next
)
2132 last_code
->block
->next
= block
;
2137 /* Call the finalizer of the ancestor. */
2138 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2140 last_code
->next
= gfc_get_code (EXEC_CALL
);
2141 last_code
= last_code
->next
;
2142 last_code
->symtree
= ancestor_wrapper
->symtree
;
2143 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2145 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2146 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2147 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2148 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2149 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2150 last_code
->ext
.actual
->next
->next
->expr
2151 = gfc_lval_expr_from_sym (fini_coarray
);
2154 gfc_free_expr (rank
);
2155 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2156 vtab_final
->ts
.interface
= final
;
2160 /* Add procedure pointers for all type-bound procedures to a vtab. */
2163 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2165 gfc_symbol
* super_type
;
2167 super_type
= gfc_get_derived_super_type (derived
);
2169 if (super_type
&& (super_type
!= derived
))
2171 /* Make sure that the PPCs appear in the same order as in the parent. */
2172 copy_vtab_proc_comps (super_type
, vtype
);
2173 /* Only needed to get the PPC initializers right. */
2174 add_procs_to_declared_vtab (super_type
, vtype
);
2177 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2178 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2180 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2181 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2185 /* Find or generate the symbol for a derived type's vtab. */
2188 gfc_find_derived_vtab (gfc_symbol
*derived
)
2191 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2192 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2193 gfc_gsymbol
*gsym
= NULL
;
2195 /* Find the top-level namespace. */
2196 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2200 /* If the type is a class container, use the underlying derived type. */
2201 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2202 derived
= gfc_get_derived_super_type (derived
);
2204 /* Find the gsymbol for the module of use associated derived types. */
2205 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2206 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2207 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2211 /* Work in the gsymbol namespace if the top-level namespace is a module.
2212 This ensures that the vtable is unique, which is required since we use
2213 its address in SELECT TYPE. */
2214 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2215 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2220 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2222 get_unique_hashed_string (tname
, derived
);
2223 sprintf (name
, "__vtab_%s", tname
);
2225 /* Look for the vtab symbol in various namespaces. */
2226 if (gsym
&& gsym
->ns
)
2228 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2233 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2235 gfc_find_symbol (name
, ns
, 0, &vtab
);
2237 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2241 gfc_get_symbol (name
, ns
, &vtab
);
2242 vtab
->ts
.type
= BT_DERIVED
;
2243 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2244 &gfc_current_locus
))
2246 vtab
->attr
.target
= 1;
2247 vtab
->attr
.save
= SAVE_IMPLICIT
;
2248 vtab
->attr
.vtab
= 1;
2249 vtab
->attr
.access
= ACCESS_PUBLIC
;
2250 gfc_set_sym_referenced (vtab
);
2251 sprintf (name
, "__vtype_%s", tname
);
2253 gfc_find_symbol (name
, ns
, 0, &vtype
);
2257 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2259 gfc_get_symbol (name
, ns
, &vtype
);
2260 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2261 &gfc_current_locus
))
2263 vtype
->attr
.access
= ACCESS_PUBLIC
;
2264 vtype
->attr
.vtype
= 1;
2265 gfc_set_sym_referenced (vtype
);
2267 /* Add component '_hash'. */
2268 if (!gfc_add_component (vtype
, "_hash", &c
))
2270 c
->ts
.type
= BT_INTEGER
;
2272 c
->attr
.access
= ACCESS_PRIVATE
;
2273 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2274 NULL
, derived
->hash_value
);
2276 /* Add component '_size'. */
2277 if (!gfc_add_component (vtype
, "_size", &c
))
2279 c
->ts
.type
= BT_INTEGER
;
2281 c
->attr
.access
= ACCESS_PRIVATE
;
2282 /* Remember the derived type in ts.u.derived,
2283 so that the correct initializer can be set later on
2284 (in gfc_conv_structure). */
2285 c
->ts
.u
.derived
= derived
;
2286 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2289 /* Add component _extends. */
2290 if (!gfc_add_component (vtype
, "_extends", &c
))
2292 c
->attr
.pointer
= 1;
2293 c
->attr
.access
= ACCESS_PRIVATE
;
2294 if (!derived
->attr
.unlimited_polymorphic
)
2295 parent
= gfc_get_derived_super_type (derived
);
2301 parent_vtab
= gfc_find_derived_vtab (parent
);
2302 c
->ts
.type
= BT_DERIVED
;
2303 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2304 c
->initializer
= gfc_get_expr ();
2305 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2306 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2307 0, &c
->initializer
->symtree
);
2311 c
->ts
.type
= BT_DERIVED
;
2312 c
->ts
.u
.derived
= vtype
;
2313 c
->initializer
= gfc_get_null_expr (NULL
);
2316 if (!derived
->attr
.unlimited_polymorphic
2317 && derived
->components
== NULL
2318 && !derived
->attr
.zero_comp
)
2320 /* At this point an error must have occurred.
2321 Prevent further errors on the vtype components. */
2326 /* Add component _def_init. */
2327 if (!gfc_add_component (vtype
, "_def_init", &c
))
2329 c
->attr
.pointer
= 1;
2330 c
->attr
.artificial
= 1;
2331 c
->attr
.access
= ACCESS_PRIVATE
;
2332 c
->ts
.type
= BT_DERIVED
;
2333 c
->ts
.u
.derived
= derived
;
2334 if (derived
->attr
.unlimited_polymorphic
2335 || derived
->attr
.abstract
)
2336 c
->initializer
= gfc_get_null_expr (NULL
);
2339 /* Construct default initialization variable. */
2340 sprintf (name
, "__def_init_%s", tname
);
2341 gfc_get_symbol (name
, ns
, &def_init
);
2342 def_init
->attr
.target
= 1;
2343 def_init
->attr
.artificial
= 1;
2344 def_init
->attr
.save
= SAVE_IMPLICIT
;
2345 def_init
->attr
.access
= ACCESS_PUBLIC
;
2346 def_init
->attr
.flavor
= FL_VARIABLE
;
2347 gfc_set_sym_referenced (def_init
);
2348 def_init
->ts
.type
= BT_DERIVED
;
2349 def_init
->ts
.u
.derived
= derived
;
2350 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2352 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2355 /* Add component _copy. */
2356 if (!gfc_add_component (vtype
, "_copy", &c
))
2358 c
->attr
.proc_pointer
= 1;
2359 c
->attr
.access
= ACCESS_PRIVATE
;
2360 c
->tb
= XCNEW (gfc_typebound_proc
);
2362 if (derived
->attr
.unlimited_polymorphic
2363 || derived
->attr
.abstract
)
2364 c
->initializer
= gfc_get_null_expr (NULL
);
2367 /* Set up namespace. */
2368 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2369 sub_ns
->sibling
= ns
->contained
;
2370 ns
->contained
= sub_ns
;
2371 sub_ns
->resolved
= 1;
2372 /* Set up procedure symbol. */
2373 sprintf (name
, "__copy_%s", tname
);
2374 gfc_get_symbol (name
, sub_ns
, ©
);
2375 sub_ns
->proc_name
= copy
;
2376 copy
->attr
.flavor
= FL_PROCEDURE
;
2377 copy
->attr
.subroutine
= 1;
2378 copy
->attr
.pure
= 1;
2379 copy
->attr
.artificial
= 1;
2380 copy
->attr
.if_source
= IFSRC_DECL
;
2381 /* This is elemental so that arrays are automatically
2382 treated correctly by the scalarizer. */
2383 copy
->attr
.elemental
= 1;
2384 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2385 copy
->module
= ns
->proc_name
->name
;
2386 gfc_set_sym_referenced (copy
);
2387 /* Set up formal arguments. */
2388 gfc_get_symbol ("src", sub_ns
, &src
);
2389 src
->ts
.type
= BT_DERIVED
;
2390 src
->ts
.u
.derived
= derived
;
2391 src
->attr
.flavor
= FL_VARIABLE
;
2392 src
->attr
.dummy
= 1;
2393 src
->attr
.artificial
= 1;
2394 src
->attr
.intent
= INTENT_IN
;
2395 gfc_set_sym_referenced (src
);
2396 copy
->formal
= gfc_get_formal_arglist ();
2397 copy
->formal
->sym
= src
;
2398 gfc_get_symbol ("dst", sub_ns
, &dst
);
2399 dst
->ts
.type
= BT_DERIVED
;
2400 dst
->ts
.u
.derived
= derived
;
2401 dst
->attr
.flavor
= FL_VARIABLE
;
2402 dst
->attr
.dummy
= 1;
2403 dst
->attr
.artificial
= 1;
2404 dst
->attr
.intent
= INTENT_INOUT
;
2405 gfc_set_sym_referenced (dst
);
2406 copy
->formal
->next
= gfc_get_formal_arglist ();
2407 copy
->formal
->next
->sym
= dst
;
2409 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2410 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2411 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2412 /* Set initializer. */
2413 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2414 c
->ts
.interface
= copy
;
2417 /* Add component _final, which contains a procedure pointer to
2418 a wrapper which handles both the freeing of allocatable
2419 components and the calls to finalization subroutines.
2420 Note: The actual wrapper function can only be generated
2421 at resolution time. */
2422 if (!gfc_add_component (vtype
, "_final", &c
))
2424 c
->attr
.proc_pointer
= 1;
2425 c
->attr
.access
= ACCESS_PRIVATE
;
2426 c
->tb
= XCNEW (gfc_typebound_proc
);
2428 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2430 /* Add procedure pointers for type-bound procedures. */
2431 if (!derived
->attr
.unlimited_polymorphic
)
2432 add_procs_to_declared_vtab (derived
, vtype
);
2436 vtab
->ts
.u
.derived
= vtype
;
2437 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2444 /* It is unexpected to have some symbols added at resolution or code
2445 generation time. We commit the changes in order to keep a clean state. */
2448 gfc_commit_symbol (vtab
);
2450 gfc_commit_symbol (vtype
);
2452 gfc_commit_symbol (def_init
);
2454 gfc_commit_symbol (copy
);
2456 gfc_commit_symbol (src
);
2458 gfc_commit_symbol (dst
);
2461 gfc_undo_symbols ();
2467 /* Check if a derived type is finalizable. That is the case if it
2468 (1) has a FINAL subroutine or
2469 (2) has a nonpointer nonallocatable component of finalizable type.
2470 If it is finalizable, return an expression containing the
2471 finalization wrapper. */
2474 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2479 /* (1) Check for FINAL subroutines. */
2480 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2483 /* (2) Check for components of finalizable type. */
2484 for (c
= derived
->components
; c
; c
= c
->next
)
2485 if (c
->ts
.type
== BT_DERIVED
2486 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2487 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2493 /* Make sure vtab is generated. */
2494 vtab
= gfc_find_derived_vtab (derived
);
2497 /* Return finalizer expression. */
2498 gfc_component
*final
;
2499 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2500 gcc_assert (strcmp (final
->name
, "_final") == 0);
2501 gcc_assert (final
->initializer
2502 && final
->initializer
->expr_type
!= EXPR_NULL
);
2503 *final_expr
= final
->initializer
;
2509 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2510 needed to support unlimited polymorphism. */
2513 find_intrinsic_vtab (gfc_typespec
*ts
)
2516 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2517 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2520 if (ts
->type
== BT_CHARACTER
&& !ts
->deferred
&& ts
->u
.cl
&& ts
->u
.cl
->length
2521 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2522 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2524 /* Find the top-level namespace. */
2525 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2531 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2533 if (ts
->type
== BT_CHARACTER
)
2534 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2537 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2539 sprintf (name
, "__vtab_%s", tname
);
2541 /* Look for the vtab symbol in the top-level namespace only. */
2542 gfc_find_symbol (name
, ns
, 0, &vtab
);
2546 gfc_get_symbol (name
, ns
, &vtab
);
2547 vtab
->ts
.type
= BT_DERIVED
;
2548 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2549 &gfc_current_locus
))
2551 vtab
->attr
.target
= 1;
2552 vtab
->attr
.save
= SAVE_IMPLICIT
;
2553 vtab
->attr
.vtab
= 1;
2554 vtab
->attr
.access
= ACCESS_PUBLIC
;
2555 gfc_set_sym_referenced (vtab
);
2556 sprintf (name
, "__vtype_%s", tname
);
2558 gfc_find_symbol (name
, ns
, 0, &vtype
);
2563 gfc_namespace
*sub_ns
;
2564 gfc_namespace
*contained
;
2567 gfc_get_symbol (name
, ns
, &vtype
);
2568 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2569 &gfc_current_locus
))
2571 vtype
->attr
.access
= ACCESS_PUBLIC
;
2572 vtype
->attr
.vtype
= 1;
2573 gfc_set_sym_referenced (vtype
);
2575 /* Add component '_hash'. */
2576 if (!gfc_add_component (vtype
, "_hash", &c
))
2578 c
->ts
.type
= BT_INTEGER
;
2580 c
->attr
.access
= ACCESS_PRIVATE
;
2581 hash
= gfc_intrinsic_hash_value (ts
);
2582 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2585 /* Add component '_size'. */
2586 if (!gfc_add_component (vtype
, "_size", &c
))
2588 c
->ts
.type
= BT_INTEGER
;
2590 c
->attr
.access
= ACCESS_PRIVATE
;
2592 /* Build a minimal expression to make use of
2593 target-memory.c/gfc_element_size for 'size'. Special handling
2594 for character arrays, that are not constant sized: to support
2595 len (str) * kind, only the kind information is stored in the
2597 e
= gfc_get_expr ();
2599 e
->expr_type
= EXPR_VARIABLE
;
2600 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2602 ts
->type
== BT_CHARACTER
2605 (int)gfc_element_size (e
));
2608 /* Add component _extends. */
2609 if (!gfc_add_component (vtype
, "_extends", &c
))
2611 c
->attr
.pointer
= 1;
2612 c
->attr
.access
= ACCESS_PRIVATE
;
2613 c
->ts
.type
= BT_VOID
;
2614 c
->initializer
= gfc_get_null_expr (NULL
);
2616 /* Add component _def_init. */
2617 if (!gfc_add_component (vtype
, "_def_init", &c
))
2619 c
->attr
.pointer
= 1;
2620 c
->attr
.access
= ACCESS_PRIVATE
;
2621 c
->ts
.type
= BT_VOID
;
2622 c
->initializer
= gfc_get_null_expr (NULL
);
2624 /* Add component _copy. */
2625 if (!gfc_add_component (vtype
, "_copy", &c
))
2627 c
->attr
.proc_pointer
= 1;
2628 c
->attr
.access
= ACCESS_PRIVATE
;
2629 c
->tb
= XCNEW (gfc_typebound_proc
);
2632 if (ts
->type
!= BT_CHARACTER
)
2633 sprintf (name
, "__copy_%s", tname
);
2636 /* __copy is always the same for characters.
2637 Check to see if copy function already exists. */
2638 sprintf (name
, "__copy_character_%d", ts
->kind
);
2639 contained
= ns
->contained
;
2640 for (; contained
; contained
= contained
->sibling
)
2641 if (contained
->proc_name
2642 && strcmp (name
, contained
->proc_name
->name
) == 0)
2644 copy
= contained
->proc_name
;
2649 /* Set up namespace. */
2650 sub_ns
= gfc_get_namespace (ns
, 0);
2651 sub_ns
->sibling
= ns
->contained
;
2652 ns
->contained
= sub_ns
;
2653 sub_ns
->resolved
= 1;
2654 /* Set up procedure symbol. */
2655 gfc_get_symbol (name
, sub_ns
, ©
);
2656 sub_ns
->proc_name
= copy
;
2657 copy
->attr
.flavor
= FL_PROCEDURE
;
2658 copy
->attr
.subroutine
= 1;
2659 copy
->attr
.pure
= 1;
2660 copy
->attr
.if_source
= IFSRC_DECL
;
2661 /* This is elemental so that arrays are automatically
2662 treated correctly by the scalarizer. */
2663 copy
->attr
.elemental
= 1;
2664 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2665 copy
->module
= ns
->proc_name
->name
;
2666 gfc_set_sym_referenced (copy
);
2667 /* Set up formal arguments. */
2668 gfc_get_symbol ("src", sub_ns
, &src
);
2669 src
->ts
.type
= ts
->type
;
2670 src
->ts
.kind
= ts
->kind
;
2671 src
->attr
.flavor
= FL_VARIABLE
;
2672 src
->attr
.dummy
= 1;
2673 src
->attr
.intent
= INTENT_IN
;
2674 gfc_set_sym_referenced (src
);
2675 copy
->formal
= gfc_get_formal_arglist ();
2676 copy
->formal
->sym
= src
;
2677 gfc_get_symbol ("dst", sub_ns
, &dst
);
2678 dst
->ts
.type
= ts
->type
;
2679 dst
->ts
.kind
= ts
->kind
;
2680 dst
->attr
.flavor
= FL_VARIABLE
;
2681 dst
->attr
.dummy
= 1;
2682 dst
->attr
.intent
= INTENT_INOUT
;
2683 gfc_set_sym_referenced (dst
);
2684 copy
->formal
->next
= gfc_get_formal_arglist ();
2685 copy
->formal
->next
->sym
= dst
;
2687 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2688 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2689 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2691 /* Set initializer. */
2692 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2693 c
->ts
.interface
= copy
;
2695 /* Add component _final. */
2696 if (!gfc_add_component (vtype
, "_final", &c
))
2698 c
->attr
.proc_pointer
= 1;
2699 c
->attr
.access
= ACCESS_PRIVATE
;
2700 c
->tb
= XCNEW (gfc_typebound_proc
);
2702 c
->initializer
= gfc_get_null_expr (NULL
);
2704 vtab
->ts
.u
.derived
= vtype
;
2705 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2712 /* It is unexpected to have some symbols added at resolution or code
2713 generation time. We commit the changes in order to keep a clean state. */
2716 gfc_commit_symbol (vtab
);
2718 gfc_commit_symbol (vtype
);
2720 gfc_commit_symbol (copy
);
2722 gfc_commit_symbol (src
);
2724 gfc_commit_symbol (dst
);
2727 gfc_undo_symbols ();
2733 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2736 gfc_find_vtab (gfc_typespec
*ts
)
2743 return gfc_find_derived_vtab (ts
->u
.derived
);
2745 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2747 return find_intrinsic_vtab (ts
);
2752 /* General worker function to find either a type-bound procedure or a
2753 type-bound user operator. */
2756 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2757 const char* name
, bool noaccess
, bool uop
,
2763 /* Set default to failure. */
2767 if (derived
->f2k_derived
)
2768 /* Set correct symbol-root. */
2769 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2770 : derived
->f2k_derived
->tb_sym_root
);
2774 /* Try to find it in the current type's namespace. */
2775 res
= gfc_find_symtree (root
, name
);
2776 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2782 if (!noaccess
&& derived
->attr
.use_assoc
2783 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2786 gfc_error ("%qs of %qs is PRIVATE at %L",
2787 name
, derived
->name
, where
);
2795 /* Otherwise, recurse on parent type if derived is an extension. */
2796 if (derived
->attr
.extension
)
2798 gfc_symbol
* super_type
;
2799 super_type
= gfc_get_derived_super_type (derived
);
2800 gcc_assert (super_type
);
2802 return find_typebound_proc_uop (super_type
, t
, name
,
2803 noaccess
, uop
, where
);
2806 /* Nothing found. */
2811 /* Find a type-bound procedure or user operator by name for a derived-type
2812 (looking recursively through the super-types). */
2815 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2816 const char* name
, bool noaccess
, locus
* where
)
2818 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2822 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2823 const char* name
, bool noaccess
, locus
* where
)
2825 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2829 /* Find a type-bound intrinsic operator looking recursively through the
2830 super-type hierarchy. */
2833 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2834 gfc_intrinsic_op op
, bool noaccess
,
2837 gfc_typebound_proc
* res
;
2839 /* Set default to failure. */
2843 /* Try to find it in the current type's namespace. */
2844 if (derived
->f2k_derived
)
2845 res
= derived
->f2k_derived
->tb_op
[op
];
2850 if (res
&& !res
->error
)
2856 if (!noaccess
&& derived
->attr
.use_assoc
2857 && res
->access
== ACCESS_PRIVATE
)
2860 gfc_error ("%qs of %qs is PRIVATE at %L",
2861 gfc_op2string (op
), derived
->name
, where
);
2869 /* Otherwise, recurse on parent type if derived is an extension. */
2870 if (derived
->attr
.extension
)
2872 gfc_symbol
* super_type
;
2873 super_type
= gfc_get_derived_super_type (derived
);
2874 gcc_assert (super_type
);
2876 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2880 /* Nothing found. */
2885 /* Get a typebound-procedure symtree or create and insert it if not yet
2886 present. This is like a very simplified version of gfc_get_sym_tree for
2887 tbp-symtrees rather than regular ones. */
2890 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2892 gfc_symtree
*result
;
2894 result
= gfc_find_symtree (*root
, name
);
2897 result
= gfc_new_symtree (root
, name
);
2898 gcc_assert (result
);
2899 result
->n
.tb
= NULL
;