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
&& derived
->components
->next
&&
228 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
229 derived
->components
->next
->ts
.u
.derived
== NULL
)
231 /* Fix up missing vtype. */
232 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
234 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
236 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
239 /* Avoid losing memory. */
240 gfc_free_ref_list (*tail
);
241 c
= gfc_find_component (derived
, name
, true, true, tail
);
244 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
253 /* This is used to add both the _data component reference and an array
254 reference to class expressions. Used in translation of intrinsic
255 array inquiry functions. */
258 gfc_add_class_array_ref (gfc_expr
*e
)
260 int rank
= CLASS_DATA (e
)->as
->rank
;
261 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
263 gfc_add_data_component (e
);
265 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
268 if (ref
->type
!= REF_ARRAY
)
270 ref
->next
= gfc_get_ref ();
272 ref
->type
= REF_ARRAY
;
273 ref
->u
.ar
.type
= AR_FULL
;
279 /* Unfortunately, class array expressions can appear in various conditions;
280 with and without both _data component and an arrayspec. This function
281 deals with that variability. The previous reference to 'ref' is to a
285 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
287 bool no_data
= false;
288 bool with_data
= false;
290 /* An array reference with no _data component. */
291 if (ref
&& ref
->type
== REF_ARRAY
293 && ref
->u
.ar
.type
!= AR_ELEMENT
)
296 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
300 /* Cover cases where _data appears, with or without an array ref. */
301 if (ref
&& ref
->type
== REF_COMPONENT
302 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
310 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
312 && ref
->type
== REF_COMPONENT
313 && ref
->next
->type
== REF_ARRAY
314 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
318 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
322 return no_data
|| with_data
;
326 /* Returns true if the expression contains a reference to a class
327 array. Notice that class array elements return false. */
330 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
340 /* Is this a class array object? ie. Is the symbol of type class? */
342 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
343 && CLASS_DATA (e
->symtree
->n
.sym
)
344 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
345 && class_array_ref_detected (e
->ref
, full_array
))
348 /* Or is this a class array component reference? */
349 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
351 if (ref
->type
== REF_COMPONENT
352 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
353 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
354 && class_array_ref_detected (ref
->next
, full_array
))
362 /* Returns true if the expression is a reference to a class
363 scalar. This function is necessary because such expressions
364 can be dressed with a reference to the _data component and so
365 have a type other than BT_CLASS. */
368 gfc_is_class_scalar_expr (gfc_expr
*e
)
375 /* Is this a class object? */
377 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
378 && CLASS_DATA (e
->symtree
->n
.sym
)
379 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
381 || (e
->ref
->type
== REF_COMPONENT
382 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
383 && e
->ref
->next
== NULL
)))
386 /* Or is the final reference BT_CLASS or _data? */
387 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
389 if (ref
->type
== REF_COMPONENT
390 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
391 && CLASS_DATA (ref
->u
.c
.component
)
392 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
393 && (ref
->next
== NULL
394 || (ref
->next
->type
== REF_COMPONENT
395 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
396 && ref
->next
->next
== NULL
)))
404 /* Tells whether the expression E is a reference to a (scalar) class container.
405 Scalar because array class containers usually have an array reference after
406 them, and gfc_fix_class_refs will add the missing "_data" component reference
410 gfc_is_class_container_ref (gfc_expr
*e
)
415 if (e
->expr_type
!= EXPR_VARIABLE
)
416 return e
->ts
.type
== BT_CLASS
;
418 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
423 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
425 if (ref
->type
!= REF_COMPONENT
)
427 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
437 /* Build an initializer for CLASS pointers,
438 initializing the _data component to the init_expr (or NULL) and the _vptr
439 component to the corresponding type (or the declared type, given by ts). */
442 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
446 gfc_symbol
*vtab
= NULL
;
448 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
449 vtab
= gfc_find_vtab (&init_expr
->ts
);
451 vtab
= gfc_find_vtab (ts
);
453 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
454 &ts
->u
.derived
->declared_at
);
457 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
459 gfc_constructor
*ctor
= gfc_constructor_get();
460 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
461 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
462 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
463 ctor
->expr
= gfc_copy_expr (init_expr
);
465 ctor
->expr
= gfc_get_null_expr (NULL
);
466 gfc_constructor_append (&init
->value
.constructor
, ctor
);
473 /* Create a unique string identifier for a derived type, composed of its name
474 and module name. This is used to construct unique names for the class
475 containers and vtab symbols. */
478 get_unique_type_string (char *string
, gfc_symbol
*derived
)
480 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
481 if (derived
->attr
.unlimited_polymorphic
)
482 strcpy (dt_name
, "STAR");
484 strcpy (dt_name
, gfc_dt_upper_string (derived
->name
));
485 if (derived
->attr
.unlimited_polymorphic
)
486 sprintf (string
, "_%s", dt_name
);
487 else if (derived
->module
)
488 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
489 else if (derived
->ns
->proc_name
)
490 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
492 sprintf (string
, "_%s", dt_name
);
496 /* A relative of 'get_unique_type_string' which makes sure the generated
497 string will not be too long (replacing it by a hash string if needed). */
500 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
502 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
503 get_unique_type_string (&tmp
[0], derived
);
504 /* If string is too long, use hash value in hex representation (allow for
505 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
506 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
507 where %d is the (co)rank which can be up to n = 15. */
508 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
510 int h
= gfc_hash_value (derived
);
511 sprintf (string
, "%X", h
);
514 strcpy (string
, tmp
);
518 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
521 gfc_hash_value (gfc_symbol
*sym
)
523 unsigned int hash
= 0;
524 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
527 get_unique_type_string (&c
[0], sym
);
530 for (i
= 0; i
< len
; i
++)
531 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
533 /* Return the hash but take the modulus for the sake of module read,
534 even though this slightly increases the chance of collision. */
535 return (hash
% 100000000);
539 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
542 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
544 unsigned int hash
= 0;
545 const char *c
= gfc_typename (ts
);
550 for (i
= 0; i
< len
; i
++)
551 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
553 /* Return the hash but take the modulus for the sake of module read,
554 even though this slightly increases the chance of collision. */
555 return (hash
% 100000000);
559 /* Get the _len component from a class/derived object storing a string.
560 For unlimited polymorphic entities a ref to the _data component is available
561 while a ref to the _len component is needed. This routine traverese the
562 ref-chain and strips the last ref to a _data from it replacing it with a
563 ref to the _len component. */
566 gfc_get_len_component (gfc_expr
*e
)
569 gfc_ref
*ref
, **last
;
571 ptr
= gfc_copy_expr (e
);
573 /* We need to remove the last _data component ref from ptr. */
579 && ref
->type
== REF_COMPONENT
580 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
582 gfc_free_ref_list (ref
);
589 /* And replace if with a ref to the _len component. */
590 gfc_add_len_component (ptr
);
595 /* Build a polymorphic CLASS entity, using the symbol that comes from
596 build_sym. A CLASS entity is represented by an encapsulating type,
597 which contains the declared type as '_data' component, plus a pointer
598 component '_vptr' which determines the dynamic type. When this CLASS
599 entity is unlimited polymorphic, then also add a component '_len' to
600 store the length of string when that is stored in it. */
603 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
606 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
615 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
617 gfc_error ("Assumed size polymorphic objects or components, such "
618 "as that at %C, have not yet been implemented");
623 /* Class container has already been built. */
626 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
627 || attr
->select_type_temporary
|| attr
->associate_var
;
630 /* We can not build the class container yet. */
633 /* Determine the name of the encapsulating type. */
634 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
635 get_unique_hashed_string (tname
, ts
->u
.derived
);
636 if ((*as
) && attr
->allocatable
)
637 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
638 else if ((*as
) && attr
->pointer
)
639 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
641 sprintf (name
, "__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
642 else if (attr
->pointer
)
643 sprintf (name
, "__class_%s_p", tname
);
644 else if (attr
->allocatable
)
645 sprintf (name
, "__class_%s_a", tname
);
647 sprintf (name
, "__class_%s_t", tname
);
649 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
651 /* Find the top-level namespace. */
652 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
657 ns
= ts
->u
.derived
->ns
;
659 gfc_find_symbol (name
, ns
, 0, &fclass
);
663 /* If not there, create a new symbol. */
664 fclass
= gfc_new_symbol (name
, ns
);
665 st
= gfc_new_symtree (&ns
->sym_root
, name
);
667 gfc_set_sym_referenced (fclass
);
669 fclass
->ts
.type
= BT_UNKNOWN
;
670 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
671 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
672 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
673 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
677 /* Add component '_data'. */
678 if (!gfc_add_component (fclass
, "_data", &c
))
681 c
->ts
.type
= BT_DERIVED
;
682 c
->attr
.access
= ACCESS_PRIVATE
;
683 c
->ts
.u
.derived
= ts
->u
.derived
;
684 c
->attr
.class_pointer
= attr
->pointer
;
685 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
686 || attr
->select_type_temporary
;
687 c
->attr
.allocatable
= attr
->allocatable
;
688 c
->attr
.dimension
= attr
->dimension
;
689 c
->attr
.codimension
= attr
->codimension
;
690 c
->attr
.abstract
= fclass
->attr
.abstract
;
692 c
->initializer
= NULL
;
694 /* Add component '_vptr'. */
695 if (!gfc_add_component (fclass
, "_vptr", &c
))
697 c
->ts
.type
= BT_DERIVED
;
698 c
->attr
.access
= ACCESS_PRIVATE
;
701 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
703 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
705 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
707 /* Add component '_len'. Only unlimited polymorphic pointers may
708 have a string assigned to them, i.e., only those need the _len
710 if (!gfc_add_component (fclass
, "_len", &c
))
712 c
->ts
.type
= BT_INTEGER
;
713 c
->ts
.kind
= gfc_charlen_int_kind
;
714 c
->attr
.access
= ACCESS_PRIVATE
;
715 c
->attr
.artificial
= 1;
718 /* Build vtab later. */
719 c
->ts
.u
.derived
= NULL
;
722 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
724 /* Since the extension field is 8 bit wide, we can only have
725 up to 255 extension levels. */
726 if (ts
->u
.derived
->attr
.extension
== 255)
728 gfc_error ("Maximum extension level reached with type %qs at %L",
729 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
733 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
734 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
735 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
738 fclass
->attr
.is_class
= 1;
739 ts
->u
.derived
= fclass
;
740 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
746 /* Add a procedure pointer component to the vtype
747 to represent a specific type-bound procedure. */
750 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
754 if (tb
->non_overridable
&& !tb
->overridden
)
757 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
761 /* Add procedure component. */
762 if (!gfc_add_component (vtype
, name
, &c
))
766 c
->tb
= XCNEW (gfc_typebound_proc
);
769 c
->attr
.procedure
= 1;
770 c
->attr
.proc_pointer
= 1;
771 c
->attr
.flavor
= FL_PROCEDURE
;
772 c
->attr
.access
= ACCESS_PRIVATE
;
773 c
->attr
.external
= 1;
775 c
->attr
.if_source
= IFSRC_IFBODY
;
777 else if (c
->attr
.proc_pointer
&& c
->tb
)
785 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
786 c
->ts
.interface
= ifc
;
788 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
789 c
->attr
.pure
= ifc
->attr
.pure
;
794 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
797 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
803 add_procs_to_declared_vtab1 (st
->left
, vtype
);
806 add_procs_to_declared_vtab1 (st
->right
, vtype
);
808 if (st
->n
.tb
&& !st
->n
.tb
->error
809 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
810 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
814 /* Copy procedure pointers components from the parent type. */
817 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
822 vtab
= gfc_find_derived_vtab (declared
);
824 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
826 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
829 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
834 /* Returns true if any of its nonpointer nonallocatable components or
835 their nonpointer nonallocatable subcomponents has a finalization
839 has_finalizer_component (gfc_symbol
*derived
)
843 for (c
= derived
->components
; c
; c
= c
->next
)
845 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
846 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
849 /* Stop infinite recursion through this function by inhibiting
850 calls when the derived type and that of the component are
852 if (c
->ts
.type
== BT_DERIVED
853 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
854 && !c
->attr
.pointer
&& !c
->attr
.allocatable
855 && has_finalizer_component (c
->ts
.u
.derived
))
863 comp_is_finalizable (gfc_component
*comp
)
865 if (comp
->attr
.proc_pointer
)
867 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
869 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
870 && (comp
->ts
.u
.derived
->attr
.alloc_comp
871 || has_finalizer_component (comp
->ts
.u
.derived
)
872 || (comp
->ts
.u
.derived
->f2k_derived
873 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
875 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
876 && CLASS_DATA (comp
)->attr
.allocatable
)
883 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
884 neither allocatable nor a pointer but has a finalizer, call it. If it
885 is a nonpointer component with allocatable components or has finalizers, walk
886 them. Either of them is required; other nonallocatables and pointers aren't
888 Note: If the component is allocatable, the DEALLOCATE handling takes care
889 of calling the appropriate finalizers, coarray deregistering, and
890 deallocation of allocatable subcomponents. */
893 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
894 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
895 gfc_namespace
*sub_ns
)
900 if (!comp_is_finalizable (comp
))
903 e
= gfc_copy_expr (expr
);
905 e
->ref
= ref
= gfc_get_ref ();
908 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
910 ref
->next
= gfc_get_ref ();
913 ref
->type
= REF_COMPONENT
;
914 ref
->u
.c
.sym
= derived
;
915 ref
->u
.c
.component
= comp
;
918 if (comp
->attr
.dimension
|| comp
->attr
.codimension
919 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
920 && (CLASS_DATA (comp
)->attr
.dimension
921 || CLASS_DATA (comp
)->attr
.codimension
)))
923 ref
->next
= gfc_get_ref ();
924 ref
->next
->type
= REF_ARRAY
;
925 ref
->next
->u
.ar
.dimen
= 0;
926 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
928 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
929 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
932 /* Call DEALLOCATE (comp, stat=ignore). */
933 if (comp
->attr
.allocatable
934 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
935 && CLASS_DATA (comp
)->attr
.allocatable
))
937 gfc_code
*dealloc
, *block
= NULL
;
939 /* Add IF (fini_coarray). */
940 if (comp
->attr
.codimension
941 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
942 && CLASS_DATA (comp
)->attr
.codimension
))
944 block
= gfc_get_code (EXEC_IF
);
947 (*code
)->next
= block
;
948 (*code
) = (*code
)->next
;
953 block
->block
= gfc_get_code (EXEC_IF
);
954 block
= block
->block
;
955 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
958 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
960 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
961 dealloc
->ext
.alloc
.list
->expr
= e
;
962 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
964 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
965 cond
->block
= gfc_get_code (EXEC_IF
);
966 cond
->block
->expr1
= gfc_get_expr ();
967 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
968 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
969 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
970 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
971 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
972 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
973 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
974 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
975 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
976 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
977 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
978 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
979 cond
->block
->next
= dealloc
;
985 (*code
)->next
= cond
;
986 (*code
) = (*code
)->next
;
991 else if (comp
->ts
.type
== BT_DERIVED
992 && comp
->ts
.u
.derived
->f2k_derived
993 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
995 /* Call FINAL_WRAPPER (comp); */
996 gfc_code
*final_wrap
;
1000 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1001 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1002 if (strcmp (c
->name
, "_final") == 0)
1006 final_wrap
= gfc_get_code (EXEC_CALL
);
1007 final_wrap
->symtree
= c
->initializer
->symtree
;
1008 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1009 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1010 final_wrap
->ext
.actual
->expr
= e
;
1014 (*code
)->next
= final_wrap
;
1015 (*code
) = (*code
)->next
;
1018 (*code
) = final_wrap
;
1024 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1025 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1032 /* Generate code equivalent to
1033 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1034 + offset, c_ptr), ptr). */
1037 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1038 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1041 gfc_expr
*expr
, *expr2
;
1043 /* C_F_POINTER(). */
1044 block
= gfc_get_code (EXEC_CALL
);
1045 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1046 block
->resolved_sym
= block
->symtree
->n
.sym
;
1047 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1048 block
->resolved_sym
->attr
.intrinsic
= 1;
1049 block
->resolved_sym
->attr
.subroutine
= 1;
1050 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1051 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1052 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1053 gfc_commit_symbol (block
->resolved_sym
);
1055 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1056 block
->ext
.actual
= gfc_get_actual_arglist ();
1057 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1058 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1060 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1062 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1064 /* TRANSFER's first argument: C_LOC (array). */
1065 expr
= gfc_get_expr ();
1066 expr
->expr_type
= EXPR_FUNCTION
;
1067 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1068 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1069 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1070 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1071 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1072 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1073 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1074 expr
->value
.function
.actual
->expr
1075 = gfc_lval_expr_from_sym (array
);
1076 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1077 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1078 expr
->ts
.type
= BT_INTEGER
;
1079 expr
->ts
.kind
= gfc_index_integer_kind
;
1082 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1083 gfc_current_locus
, 3, expr
,
1084 gfc_get_int_expr (gfc_index_integer_kind
,
1086 expr2
->ts
.type
= BT_INTEGER
;
1087 expr2
->ts
.kind
= gfc_index_integer_kind
;
1089 /* <array addr> + <offset>. */
1090 block
->ext
.actual
->expr
= gfc_get_expr ();
1091 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1092 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1093 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1094 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1095 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1097 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1098 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1099 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1100 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1106 /* Calculates the offset to the (idx+1)th element of an array, taking the
1107 stride into account. It generates the code:
1110 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1112 offset = offset * byte_stride. */
1115 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1116 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1117 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1118 gfc_code
*block
, gfc_namespace
*sub_ns
)
1121 gfc_expr
*expr
, *expr2
;
1124 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1125 block
= block
->next
;
1126 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1127 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1130 iter
= gfc_get_iterator ();
1131 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1132 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1133 iter
->end
= gfc_copy_expr (rank
);
1134 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1135 block
->next
= gfc_get_code (EXEC_DO
);
1136 block
= block
->next
;
1137 block
->ext
.iterator
= iter
;
1138 block
->block
= gfc_get_code (EXEC_DO
);
1140 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1143 /* mod (idx, sizes(idx2)). */
1144 expr
= gfc_lval_expr_from_sym (sizes
);
1145 expr
->ref
= gfc_get_ref ();
1146 expr
->ref
->type
= REF_ARRAY
;
1147 expr
->ref
->u
.ar
.as
= sizes
->as
;
1148 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1149 expr
->ref
->u
.ar
.dimen
= 1;
1150 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1151 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1153 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1154 gfc_current_locus
, 2,
1155 gfc_lval_expr_from_sym (idx
), expr
);
1158 /* (...) / sizes(idx2-1). */
1159 expr2
= gfc_get_expr ();
1160 expr2
->expr_type
= EXPR_OP
;
1161 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1162 expr2
->value
.op
.op1
= expr
;
1163 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1164 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1165 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1166 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1167 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1168 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1169 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1170 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1171 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1172 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1173 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1174 = gfc_lval_expr_from_sym (idx2
);
1175 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1176 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1177 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1178 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1179 expr2
->ts
= idx
->ts
;
1181 /* ... * strides(idx2). */
1182 expr
= gfc_get_expr ();
1183 expr
->expr_type
= EXPR_OP
;
1184 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1185 expr
->value
.op
.op1
= expr2
;
1186 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1187 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1188 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1189 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1190 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1191 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1192 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1193 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1196 /* offset = offset + ... */
1197 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1198 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1199 block
->block
->next
->expr2
= gfc_get_expr ();
1200 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1201 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1202 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1203 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1204 block
->block
->next
->expr2
->ts
= idx
->ts
;
1206 /* After the loop: offset = offset * byte_stride. */
1207 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1208 block
= block
->next
;
1209 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1210 block
->expr2
= gfc_get_expr ();
1211 block
->expr2
->expr_type
= EXPR_OP
;
1212 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1213 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1214 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1215 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1220 /* Insert code of the following form:
1223 integer(c_intptr_t) :: i
1225 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1226 && (is_contiguous || !final_rank3->attr.contiguous
1227 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1228 || 0 == STORAGE_SIZE (array)) then
1229 call final_rank3 (array)
1232 integer(c_intptr_t) :: offset, j
1233 type(t) :: tmp(shape (array))
1235 do i = 0, size (array)-1
1236 offset = obtain_offset(i, strides, sizes, byte_stride)
1237 addr = transfer (c_loc (array), addr) + offset
1238 call c_f_pointer (transfer (addr, cptr), ptr)
1240 addr = transfer (c_loc (tmp), addr)
1241 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1242 call c_f_pointer (transfer (addr, cptr), ptr2)
1245 call final_rank3 (tmp)
1251 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1252 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1253 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1255 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1256 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1257 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1258 gfc_namespace
*sub_ns
)
1260 gfc_symbol
*tmp_array
, *ptr2
;
1261 gfc_expr
*size_expr
, *offset2
, *expr
;
1267 block
->next
= gfc_get_code (EXEC_IF
);
1268 block
= block
->next
;
1270 block
->block
= gfc_get_code (EXEC_IF
);
1271 block
= block
->block
;
1273 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1274 size_expr
= gfc_get_expr ();
1275 size_expr
->where
= gfc_current_locus
;
1276 size_expr
->expr_type
= EXPR_OP
;
1277 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1279 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1280 size_expr
->value
.op
.op1
1281 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1282 "storage_size", gfc_current_locus
, 2,
1283 gfc_lval_expr_from_sym (array
),
1284 gfc_get_int_expr (gfc_index_integer_kind
,
1287 /* NUMERIC_STORAGE_SIZE. */
1288 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1289 gfc_character_storage_size
);
1290 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1291 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1293 /* IF condition: (stride == size_expr
1294 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1296 || 0 == size_expr. */
1297 block
->expr1
= gfc_get_expr ();
1298 block
->expr1
->ts
.type
= BT_LOGICAL
;
1299 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1300 block
->expr1
->expr_type
= EXPR_OP
;
1301 block
->expr1
->where
= gfc_current_locus
;
1303 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1305 /* byte_stride == size_expr */
1306 expr
= gfc_get_expr ();
1307 expr
->ts
.type
= BT_LOGICAL
;
1308 expr
->ts
.kind
= gfc_default_logical_kind
;
1309 expr
->expr_type
= EXPR_OP
;
1310 expr
->where
= gfc_current_locus
;
1311 expr
->value
.op
.op
= INTRINSIC_EQ
;
1313 = gfc_lval_expr_from_sym (byte_stride
);
1314 expr
->value
.op
.op2
= size_expr
;
1316 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1317 add is_contiguous check. */
1319 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1320 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1323 expr2
= gfc_get_expr ();
1324 expr2
->ts
.type
= BT_LOGICAL
;
1325 expr2
->ts
.kind
= gfc_default_logical_kind
;
1326 expr2
->expr_type
= EXPR_OP
;
1327 expr2
->where
= gfc_current_locus
;
1328 expr2
->value
.op
.op
= INTRINSIC_AND
;
1329 expr2
->value
.op
.op1
= expr
;
1330 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1334 block
->expr1
->value
.op
.op1
= expr
;
1336 /* 0 == size_expr */
1337 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1338 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1339 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1340 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1341 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1342 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1343 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1344 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1345 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1347 /* IF body: call final subroutine. */
1348 block
->next
= gfc_get_code (EXEC_CALL
);
1349 block
->next
->symtree
= fini
->proc_tree
;
1350 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1351 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1352 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1353 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1354 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1358 block
->block
= gfc_get_code (EXEC_IF
);
1359 block
= block
->block
;
1361 /* BLOCK ... END BLOCK. */
1362 block
->next
= gfc_get_code (EXEC_BLOCK
);
1363 block
= block
->next
;
1365 ns
= gfc_build_block_ns (sub_ns
);
1366 block
->ext
.block
.ns
= ns
;
1367 block
->ext
.block
.assoc
= NULL
;
1369 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1370 ptr2
->ts
.type
= BT_DERIVED
;
1371 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1372 ptr2
->attr
.flavor
= FL_VARIABLE
;
1373 ptr2
->attr
.pointer
= 1;
1374 ptr2
->attr
.artificial
= 1;
1375 gfc_set_sym_referenced (ptr2
);
1376 gfc_commit_symbol (ptr2
);
1378 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1379 tmp_array
->ts
.type
= BT_DERIVED
;
1380 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1381 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1382 tmp_array
->attr
.dimension
= 1;
1383 tmp_array
->attr
.artificial
= 1;
1384 tmp_array
->as
= gfc_get_array_spec();
1385 tmp_array
->attr
.intent
= INTENT_INOUT
;
1386 tmp_array
->as
->type
= AS_EXPLICIT
;
1387 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1389 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1391 gfc_expr
*shape_expr
;
1392 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1394 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1396 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1397 gfc_current_locus
, 3,
1398 gfc_lval_expr_from_sym (array
),
1399 gfc_get_int_expr (gfc_default_integer_kind
,
1401 gfc_get_int_expr (gfc_default_integer_kind
,
1403 gfc_index_integer_kind
));
1404 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1405 tmp_array
->as
->upper
[i
] = shape_expr
;
1407 gfc_set_sym_referenced (tmp_array
);
1408 gfc_commit_symbol (tmp_array
);
1411 iter
= gfc_get_iterator ();
1412 iter
->var
= gfc_lval_expr_from_sym (idx
);
1413 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1414 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1415 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1417 block
= gfc_get_code (EXEC_DO
);
1419 block
->ext
.iterator
= iter
;
1420 block
->block
= gfc_get_code (EXEC_DO
);
1422 /* Offset calculation for the new array: idx * size of type (in bytes). */
1423 offset2
= gfc_get_expr ();
1424 offset2
->expr_type
= EXPR_OP
;
1425 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1426 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1427 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1428 offset2
->ts
= byte_stride
->ts
;
1430 /* Offset calculation of "array". */
1431 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1432 byte_stride
, rank
, block
->block
, sub_ns
);
1435 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1436 + idx * stride, c_ptr), ptr). */
1437 block2
->next
= finalization_scalarizer (array
, ptr
,
1438 gfc_lval_expr_from_sym (offset
),
1440 block2
= block2
->next
;
1441 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1442 block2
= block2
->next
;
1445 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1446 block2
= block2
->next
;
1447 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1448 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1450 /* Call now the user's final subroutine. */
1451 block
->next
= gfc_get_code (EXEC_CALL
);
1452 block
= block
->next
;
1453 block
->symtree
= fini
->proc_tree
;
1454 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1455 block
->ext
.actual
= gfc_get_actual_arglist ();
1456 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1458 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1464 iter
= gfc_get_iterator ();
1465 iter
->var
= gfc_lval_expr_from_sym (idx
);
1466 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1467 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1468 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1470 block
->next
= gfc_get_code (EXEC_DO
);
1471 block
= block
->next
;
1472 block
->ext
.iterator
= iter
;
1473 block
->block
= gfc_get_code (EXEC_DO
);
1475 /* Offset calculation of "array". */
1476 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1477 byte_stride
, rank
, block
->block
, sub_ns
);
1480 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1481 + offset, c_ptr), ptr). */
1482 block2
->next
= finalization_scalarizer (array
, ptr
,
1483 gfc_lval_expr_from_sym (offset
),
1485 block2
= block2
->next
;
1486 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1487 gfc_copy_expr (offset2
), sub_ns
);
1488 block2
= block2
->next
;
1491 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1492 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1493 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1497 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1498 derived type "derived". The function first calls the approriate FINAL
1499 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1500 components (but not the inherited ones). Last, it calls the wrapper
1501 subroutine of the parent. The generated wrapper procedure takes as argument
1502 an assumed-rank array.
1503 If neither allocatable components nor FINAL subroutines exists, the vtab
1504 will contain a NULL pointer.
1505 The generated function has the form
1506 _final(assumed-rank array, stride, skip_corarray)
1507 where the array has to be contiguous (except of the lowest dimension). The
1508 stride (in bytes) is used to allow different sizes for ancestor types by
1509 skipping over the additionally added components in the scalarizer. If
1510 "fini_coarray" is false, coarray components are not finalized to allow for
1511 the correct semantic with intrinsic assignment. */
1514 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1515 const char *tname
, gfc_component
*vtab_final
)
1517 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1518 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1519 gfc_component
*comp
;
1520 gfc_namespace
*sub_ns
;
1521 gfc_code
*last_code
, *block
;
1522 char name
[GFC_MAX_SYMBOL_LEN
+1];
1523 bool finalizable_comp
= false;
1524 bool expr_null_wrapper
= false;
1525 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1528 if (derived
->attr
.unlimited_polymorphic
)
1530 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1534 /* Search for the ancestor's finalizers. */
1535 if (derived
->attr
.extension
&& derived
->components
1536 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1537 || has_finalizer_component (derived
)))
1540 gfc_component
*comp
;
1542 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1543 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1544 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1546 ancestor_wrapper
= comp
->initializer
;
1551 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1552 components: Return a NULL() expression; we defer this a bit to have have
1553 an interface declaration. */
1554 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1555 && !derived
->attr
.alloc_comp
1556 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1557 && !has_finalizer_component (derived
))
1558 expr_null_wrapper
= true;
1560 /* Check whether there are new allocatable components. */
1561 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1563 if (comp
== derived
->components
&& derived
->attr
.extension
1564 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1567 finalizable_comp
|= comp_is_finalizable (comp
);
1570 /* If there is no new finalizer and no new allocatable, return with
1571 an expr to the ancestor's one. */
1572 if (!expr_null_wrapper
&& !finalizable_comp
1573 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1575 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1576 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1577 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1578 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1582 /* We now create a wrapper, which does the following:
1583 1. Call the suitable finalization subroutine for this type
1584 2. Loop over all noninherited allocatable components and noninherited
1585 components with allocatable components and DEALLOCATE those; this will
1586 take care of finalizers, coarray deregistering and allocatable
1588 3. Call the ancestor's finalizer. */
1590 /* Declare the wrapper function; it takes an assumed-rank array
1591 and a VALUE logical as arguments. */
1593 /* Set up the namespace. */
1594 sub_ns
= gfc_get_namespace (ns
, 0);
1595 sub_ns
->sibling
= ns
->contained
;
1596 if (!expr_null_wrapper
)
1597 ns
->contained
= sub_ns
;
1598 sub_ns
->resolved
= 1;
1600 /* Set up the procedure symbol. */
1601 sprintf (name
, "__final_%s", tname
);
1602 gfc_get_symbol (name
, sub_ns
, &final
);
1603 sub_ns
->proc_name
= final
;
1604 final
->attr
.flavor
= FL_PROCEDURE
;
1605 final
->attr
.function
= 1;
1606 final
->attr
.pure
= 0;
1607 final
->result
= final
;
1608 final
->ts
.type
= BT_INTEGER
;
1610 final
->attr
.artificial
= 1;
1611 final
->attr
.always_explicit
= 1;
1612 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1613 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1614 final
->module
= ns
->proc_name
->name
;
1615 gfc_set_sym_referenced (final
);
1616 gfc_commit_symbol (final
);
1618 /* Set up formal argument. */
1619 gfc_get_symbol ("array", sub_ns
, &array
);
1620 array
->ts
.type
= BT_DERIVED
;
1621 array
->ts
.u
.derived
= derived
;
1622 array
->attr
.flavor
= FL_VARIABLE
;
1623 array
->attr
.dummy
= 1;
1624 array
->attr
.contiguous
= 1;
1625 array
->attr
.dimension
= 1;
1626 array
->attr
.artificial
= 1;
1627 array
->as
= gfc_get_array_spec();
1628 array
->as
->type
= AS_ASSUMED_RANK
;
1629 array
->as
->rank
= -1;
1630 array
->attr
.intent
= INTENT_INOUT
;
1631 gfc_set_sym_referenced (array
);
1632 final
->formal
= gfc_get_formal_arglist ();
1633 final
->formal
->sym
= array
;
1634 gfc_commit_symbol (array
);
1636 /* Set up formal argument. */
1637 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1638 byte_stride
->ts
.type
= BT_INTEGER
;
1639 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1640 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1641 byte_stride
->attr
.dummy
= 1;
1642 byte_stride
->attr
.value
= 1;
1643 byte_stride
->attr
.artificial
= 1;
1644 gfc_set_sym_referenced (byte_stride
);
1645 final
->formal
->next
= gfc_get_formal_arglist ();
1646 final
->formal
->next
->sym
= byte_stride
;
1647 gfc_commit_symbol (byte_stride
);
1649 /* Set up formal argument. */
1650 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1651 fini_coarray
->ts
.type
= BT_LOGICAL
;
1652 fini_coarray
->ts
.kind
= 1;
1653 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1654 fini_coarray
->attr
.dummy
= 1;
1655 fini_coarray
->attr
.value
= 1;
1656 fini_coarray
->attr
.artificial
= 1;
1657 gfc_set_sym_referenced (fini_coarray
);
1658 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1659 final
->formal
->next
->next
->sym
= fini_coarray
;
1660 gfc_commit_symbol (fini_coarray
);
1662 /* Return with a NULL() expression but with an interface which has
1663 the formal arguments. */
1664 if (expr_null_wrapper
)
1666 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1667 vtab_final
->ts
.interface
= final
;
1671 /* Local variables. */
1673 gfc_get_symbol ("idx", sub_ns
, &idx
);
1674 idx
->ts
.type
= BT_INTEGER
;
1675 idx
->ts
.kind
= gfc_index_integer_kind
;
1676 idx
->attr
.flavor
= FL_VARIABLE
;
1677 idx
->attr
.artificial
= 1;
1678 gfc_set_sym_referenced (idx
);
1679 gfc_commit_symbol (idx
);
1681 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1682 idx2
->ts
.type
= BT_INTEGER
;
1683 idx2
->ts
.kind
= gfc_index_integer_kind
;
1684 idx2
->attr
.flavor
= FL_VARIABLE
;
1685 idx2
->attr
.artificial
= 1;
1686 gfc_set_sym_referenced (idx2
);
1687 gfc_commit_symbol (idx2
);
1689 gfc_get_symbol ("offset", sub_ns
, &offset
);
1690 offset
->ts
.type
= BT_INTEGER
;
1691 offset
->ts
.kind
= gfc_index_integer_kind
;
1692 offset
->attr
.flavor
= FL_VARIABLE
;
1693 offset
->attr
.artificial
= 1;
1694 gfc_set_sym_referenced (offset
);
1695 gfc_commit_symbol (offset
);
1697 /* Create RANK expression. */
1698 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1699 gfc_current_locus
, 1,
1700 gfc_lval_expr_from_sym (array
));
1701 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1702 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1704 /* Create is_contiguous variable. */
1705 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1706 is_contiguous
->ts
.type
= BT_LOGICAL
;
1707 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1708 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1709 is_contiguous
->attr
.artificial
= 1;
1710 gfc_set_sym_referenced (is_contiguous
);
1711 gfc_commit_symbol (is_contiguous
);
1713 /* Create "sizes(0..rank)" variable, which contains the multiplied
1714 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1715 sizes(2) = sizes(1) * extent(dim=2) etc. */
1716 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1717 sizes
->ts
.type
= BT_INTEGER
;
1718 sizes
->ts
.kind
= gfc_index_integer_kind
;
1719 sizes
->attr
.flavor
= FL_VARIABLE
;
1720 sizes
->attr
.dimension
= 1;
1721 sizes
->attr
.artificial
= 1;
1722 sizes
->as
= gfc_get_array_spec();
1723 sizes
->attr
.intent
= INTENT_INOUT
;
1724 sizes
->as
->type
= AS_EXPLICIT
;
1725 sizes
->as
->rank
= 1;
1726 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1727 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1728 gfc_set_sym_referenced (sizes
);
1729 gfc_commit_symbol (sizes
);
1731 /* Create "strides(1..rank)" variable, which contains the strides per
1733 gfc_get_symbol ("strides", sub_ns
, &strides
);
1734 strides
->ts
.type
= BT_INTEGER
;
1735 strides
->ts
.kind
= gfc_index_integer_kind
;
1736 strides
->attr
.flavor
= FL_VARIABLE
;
1737 strides
->attr
.dimension
= 1;
1738 strides
->attr
.artificial
= 1;
1739 strides
->as
= gfc_get_array_spec();
1740 strides
->attr
.intent
= INTENT_INOUT
;
1741 strides
->as
->type
= AS_EXPLICIT
;
1742 strides
->as
->rank
= 1;
1743 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1744 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1745 gfc_set_sym_referenced (strides
);
1746 gfc_commit_symbol (strides
);
1749 /* Set return value to 0. */
1750 last_code
= gfc_get_code (EXEC_ASSIGN
);
1751 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1752 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1753 sub_ns
->code
= last_code
;
1755 /* Set: is_contiguous = .true. */
1756 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1757 last_code
= last_code
->next
;
1758 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1759 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1760 &gfc_current_locus
, true);
1762 /* Set: sizes(0) = 1. */
1763 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1764 last_code
= last_code
->next
;
1765 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1766 last_code
->expr1
->ref
= gfc_get_ref ();
1767 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1768 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1769 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1770 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1771 last_code
->expr1
->ref
->u
.ar
.start
[0]
1772 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1773 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1774 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1778 strides(idx) = _F._stride (array, dim=idx)
1779 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1780 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1784 iter
= gfc_get_iterator ();
1785 iter
->var
= gfc_lval_expr_from_sym (idx
);
1786 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1787 iter
->end
= gfc_copy_expr (rank
);
1788 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1789 last_code
->next
= gfc_get_code (EXEC_DO
);
1790 last_code
= last_code
->next
;
1791 last_code
->ext
.iterator
= iter
;
1792 last_code
->block
= gfc_get_code (EXEC_DO
);
1794 /* strides(idx) = _F._stride(array,dim=idx). */
1795 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1796 block
= last_code
->block
->next
;
1798 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1799 block
->expr1
->ref
= gfc_get_ref ();
1800 block
->expr1
->ref
->type
= REF_ARRAY
;
1801 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1802 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1803 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1804 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1805 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1807 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1808 gfc_current_locus
, 2,
1809 gfc_lval_expr_from_sym (array
),
1810 gfc_lval_expr_from_sym (idx
));
1812 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1813 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1814 block
= block
->next
;
1816 /* sizes(idx) = ... */
1817 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1818 block
->expr1
->ref
= gfc_get_ref ();
1819 block
->expr1
->ref
->type
= REF_ARRAY
;
1820 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1821 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1822 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1823 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1824 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1826 block
->expr2
= gfc_get_expr ();
1827 block
->expr2
->expr_type
= EXPR_OP
;
1828 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1831 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1832 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1833 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1834 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1835 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1836 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1837 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1838 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1839 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1840 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1841 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1842 = gfc_lval_expr_from_sym (idx
);
1843 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1844 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1845 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1846 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1848 /* size(array, dim=idx, kind=index_kind). */
1849 block
->expr2
->value
.op
.op2
1850 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1851 gfc_current_locus
, 3,
1852 gfc_lval_expr_from_sym (array
),
1853 gfc_lval_expr_from_sym (idx
),
1854 gfc_get_int_expr (gfc_index_integer_kind
,
1856 gfc_index_integer_kind
));
1857 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1858 block
->expr2
->ts
= idx
->ts
;
1860 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1861 block
->next
= gfc_get_code (EXEC_IF
);
1862 block
= block
->next
;
1864 block
->block
= gfc_get_code (EXEC_IF
);
1865 block
= block
->block
;
1867 /* if condition: strides(idx) /= sizes(idx-1). */
1868 block
->expr1
= gfc_get_expr ();
1869 block
->expr1
->ts
.type
= BT_LOGICAL
;
1870 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1871 block
->expr1
->expr_type
= EXPR_OP
;
1872 block
->expr1
->where
= gfc_current_locus
;
1873 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1875 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1876 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1877 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1878 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1879 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1880 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1881 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1882 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1884 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1885 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1886 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1887 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1888 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1889 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1890 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1891 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1892 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1893 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1894 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1895 = gfc_lval_expr_from_sym (idx
);
1896 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1897 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1898 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1899 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1901 /* if body: is_contiguous = .false. */
1902 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1903 block
= block
->next
;
1904 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1905 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1906 &gfc_current_locus
, false);
1908 /* Obtain the size (number of elements) of "array" MINUS ONE,
1909 which is used in the scalarization. */
1910 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1911 nelem
->ts
.type
= BT_INTEGER
;
1912 nelem
->ts
.kind
= gfc_index_integer_kind
;
1913 nelem
->attr
.flavor
= FL_VARIABLE
;
1914 nelem
->attr
.artificial
= 1;
1915 gfc_set_sym_referenced (nelem
);
1916 gfc_commit_symbol (nelem
);
1918 /* nelem = sizes (rank) - 1. */
1919 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1920 last_code
= last_code
->next
;
1922 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1924 last_code
->expr2
= gfc_get_expr ();
1925 last_code
->expr2
->expr_type
= EXPR_OP
;
1926 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1927 last_code
->expr2
->value
.op
.op2
1928 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1929 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1931 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1932 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1933 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1934 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1935 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1936 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1937 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1938 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1940 /* Call final subroutines. We now generate code like:
1942 integer, pointer :: ptr
1944 integer(c_intptr_t) :: i, addr
1946 select case (rank (array))
1948 ! If needed, the array is packed
1949 call final_rank3 (array)
1951 do i = 0, size (array)-1
1952 addr = transfer (c_loc (array), addr) + i * stride
1953 call c_f_pointer (transfer (addr, cptr), ptr)
1954 call elemental_final (ptr)
1958 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1960 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1962 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1963 ptr
->ts
.type
= BT_DERIVED
;
1964 ptr
->ts
.u
.derived
= derived
;
1965 ptr
->attr
.flavor
= FL_VARIABLE
;
1966 ptr
->attr
.pointer
= 1;
1967 ptr
->attr
.artificial
= 1;
1968 gfc_set_sym_referenced (ptr
);
1969 gfc_commit_symbol (ptr
);
1971 /* SELECT CASE (RANK (array)). */
1972 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1973 last_code
= last_code
->next
;
1974 last_code
->expr1
= gfc_copy_expr (rank
);
1977 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1979 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1980 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1986 /* CASE (fini_rank). */
1989 block
->block
= gfc_get_code (EXEC_SELECT
);
1990 block
= block
->block
;
1994 block
= gfc_get_code (EXEC_SELECT
);
1995 last_code
->block
= block
;
1997 block
->ext
.block
.case_list
= gfc_get_case ();
1998 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1999 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2000 block
->ext
.block
.case_list
->low
2001 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2002 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2004 block
->ext
.block
.case_list
->low
2005 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2006 block
->ext
.block
.case_list
->high
2007 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2009 /* CALL fini_rank (array) - possibly with packing. */
2010 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2011 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2012 idx
, ptr
, nelem
, strides
,
2013 sizes
, idx2
, offset
, is_contiguous
,
2017 block
->next
= gfc_get_code (EXEC_CALL
);
2018 block
->next
->symtree
= fini
->proc_tree
;
2019 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2020 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2021 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2025 /* Elemental call - scalarized. */
2031 block
->block
= gfc_get_code (EXEC_SELECT
);
2032 block
= block
->block
;
2036 block
= gfc_get_code (EXEC_SELECT
);
2037 last_code
->block
= block
;
2039 block
->ext
.block
.case_list
= gfc_get_case ();
2042 iter
= gfc_get_iterator ();
2043 iter
->var
= gfc_lval_expr_from_sym (idx
);
2044 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2045 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2046 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2047 block
->next
= gfc_get_code (EXEC_DO
);
2048 block
= block
->next
;
2049 block
->ext
.iterator
= iter
;
2050 block
->block
= gfc_get_code (EXEC_DO
);
2052 /* Offset calculation. */
2053 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2054 byte_stride
, rank
, block
->block
,
2058 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2059 + offset, c_ptr), ptr). */
2061 = finalization_scalarizer (array
, ptr
,
2062 gfc_lval_expr_from_sym (offset
),
2064 block
= block
->next
;
2066 /* CALL final_elemental (array). */
2067 block
->next
= gfc_get_code (EXEC_CALL
);
2068 block
= block
->next
;
2069 block
->symtree
= fini_elem
->proc_tree
;
2070 block
->resolved_sym
= fini_elem
->proc_sym
;
2071 block
->ext
.actual
= gfc_get_actual_arglist ();
2072 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2076 /* Finalize and deallocate allocatable components. The same manual
2077 scalarization is used as above. */
2079 if (finalizable_comp
)
2082 gfc_code
*block
= NULL
;
2086 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2087 ptr
->ts
.type
= BT_DERIVED
;
2088 ptr
->ts
.u
.derived
= derived
;
2089 ptr
->attr
.flavor
= FL_VARIABLE
;
2090 ptr
->attr
.pointer
= 1;
2091 ptr
->attr
.artificial
= 1;
2092 gfc_set_sym_referenced (ptr
);
2093 gfc_commit_symbol (ptr
);
2096 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2097 stat
->attr
.flavor
= FL_VARIABLE
;
2098 stat
->attr
.artificial
= 1;
2099 stat
->ts
.type
= BT_INTEGER
;
2100 stat
->ts
.kind
= gfc_default_integer_kind
;
2101 gfc_set_sym_referenced (stat
);
2102 gfc_commit_symbol (stat
);
2105 iter
= gfc_get_iterator ();
2106 iter
->var
= gfc_lval_expr_from_sym (idx
);
2107 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2108 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2109 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2110 last_code
->next
= gfc_get_code (EXEC_DO
);
2111 last_code
= last_code
->next
;
2112 last_code
->ext
.iterator
= iter
;
2113 last_code
->block
= gfc_get_code (EXEC_DO
);
2115 /* Offset calculation. */
2116 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2117 byte_stride
, rank
, last_code
->block
,
2121 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2122 + idx * stride, c_ptr), ptr). */
2123 block
->next
= finalization_scalarizer (array
, ptr
,
2124 gfc_lval_expr_from_sym(offset
),
2126 block
= block
->next
;
2128 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2130 if (comp
== derived
->components
&& derived
->attr
.extension
2131 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2134 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2135 stat
, fini_coarray
, &block
, sub_ns
);
2136 if (!last_code
->block
->next
)
2137 last_code
->block
->next
= block
;
2142 /* Call the finalizer of the ancestor. */
2143 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2145 last_code
->next
= gfc_get_code (EXEC_CALL
);
2146 last_code
= last_code
->next
;
2147 last_code
->symtree
= ancestor_wrapper
->symtree
;
2148 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2150 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2151 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2152 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2153 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2154 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2155 last_code
->ext
.actual
->next
->next
->expr
2156 = gfc_lval_expr_from_sym (fini_coarray
);
2159 gfc_free_expr (rank
);
2160 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2161 vtab_final
->ts
.interface
= final
;
2165 /* Add procedure pointers for all type-bound procedures to a vtab. */
2168 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2170 gfc_symbol
* super_type
;
2172 super_type
= gfc_get_derived_super_type (derived
);
2174 if (super_type
&& (super_type
!= derived
))
2176 /* Make sure that the PPCs appear in the same order as in the parent. */
2177 copy_vtab_proc_comps (super_type
, vtype
);
2178 /* Only needed to get the PPC initializers right. */
2179 add_procs_to_declared_vtab (super_type
, vtype
);
2182 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2183 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2185 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2186 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2190 /* Find or generate the symbol for a derived type's vtab. */
2193 gfc_find_derived_vtab (gfc_symbol
*derived
)
2196 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2197 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2198 gfc_gsymbol
*gsym
= NULL
;
2199 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2201 /* Find the top-level namespace. */
2202 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2206 /* If the type is a class container, use the underlying derived type. */
2207 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2208 derived
= gfc_get_derived_super_type (derived
);
2210 /* Find the gsymbol for the module of use associated derived types. */
2211 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2212 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2213 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2217 /* Work in the gsymbol namespace if the top-level namespace is a module.
2218 This ensures that the vtable is unique, which is required since we use
2219 its address in SELECT TYPE. */
2220 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2221 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2226 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2228 get_unique_hashed_string (tname
, derived
);
2229 sprintf (name
, "__vtab_%s", tname
);
2231 /* Look for the vtab symbol in various namespaces. */
2232 if (gsym
&& gsym
->ns
)
2234 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2239 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2241 gfc_find_symbol (name
, ns
, 0, &vtab
);
2243 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2247 gfc_get_symbol (name
, ns
, &vtab
);
2248 vtab
->ts
.type
= BT_DERIVED
;
2249 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2250 &gfc_current_locus
))
2252 vtab
->attr
.target
= 1;
2253 vtab
->attr
.save
= SAVE_IMPLICIT
;
2254 vtab
->attr
.vtab
= 1;
2255 vtab
->attr
.access
= ACCESS_PUBLIC
;
2256 gfc_set_sym_referenced (vtab
);
2257 sprintf (name
, "__vtype_%s", tname
);
2259 gfc_find_symbol (name
, ns
, 0, &vtype
);
2263 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2266 /* Is this a derived type with recursive allocatable
2268 c
= (derived
->attr
.unlimited_polymorphic
2269 || derived
->attr
.abstract
) ?
2270 NULL
: derived
->components
;
2271 for (; c
; c
= c
->next
)
2272 if (c
->ts
.type
== BT_DERIVED
2273 && c
->ts
.u
.derived
== derived
)
2279 gfc_get_symbol (name
, ns
, &vtype
);
2280 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2281 &gfc_current_locus
))
2283 vtype
->attr
.access
= ACCESS_PUBLIC
;
2284 vtype
->attr
.vtype
= 1;
2285 gfc_set_sym_referenced (vtype
);
2287 /* Add component '_hash'. */
2288 if (!gfc_add_component (vtype
, "_hash", &c
))
2290 c
->ts
.type
= BT_INTEGER
;
2292 c
->attr
.access
= ACCESS_PRIVATE
;
2293 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2294 NULL
, derived
->hash_value
);
2296 /* Add component '_size'. */
2297 if (!gfc_add_component (vtype
, "_size", &c
))
2299 c
->ts
.type
= BT_INTEGER
;
2301 c
->attr
.access
= ACCESS_PRIVATE
;
2302 /* Remember the derived type in ts.u.derived,
2303 so that the correct initializer can be set later on
2304 (in gfc_conv_structure). */
2305 c
->ts
.u
.derived
= derived
;
2306 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2309 /* Add component _extends. */
2310 if (!gfc_add_component (vtype
, "_extends", &c
))
2312 c
->attr
.pointer
= 1;
2313 c
->attr
.access
= ACCESS_PRIVATE
;
2314 if (!derived
->attr
.unlimited_polymorphic
)
2315 parent
= gfc_get_derived_super_type (derived
);
2321 parent_vtab
= gfc_find_derived_vtab (parent
);
2322 c
->ts
.type
= BT_DERIVED
;
2323 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2324 c
->initializer
= gfc_get_expr ();
2325 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2326 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2327 0, &c
->initializer
->symtree
);
2331 c
->ts
.type
= BT_DERIVED
;
2332 c
->ts
.u
.derived
= vtype
;
2333 c
->initializer
= gfc_get_null_expr (NULL
);
2336 if (!derived
->attr
.unlimited_polymorphic
2337 && derived
->components
== NULL
2338 && !derived
->attr
.zero_comp
)
2340 /* At this point an error must have occurred.
2341 Prevent further errors on the vtype components. */
2346 /* Add component _def_init. */
2347 if (!gfc_add_component (vtype
, "_def_init", &c
))
2349 c
->attr
.pointer
= 1;
2350 c
->attr
.artificial
= 1;
2351 c
->attr
.access
= ACCESS_PRIVATE
;
2352 c
->ts
.type
= BT_DERIVED
;
2353 c
->ts
.u
.derived
= derived
;
2354 if (derived
->attr
.unlimited_polymorphic
2355 || derived
->attr
.abstract
)
2356 c
->initializer
= gfc_get_null_expr (NULL
);
2359 /* Construct default initialization variable. */
2360 sprintf (name
, "__def_init_%s", tname
);
2361 gfc_get_symbol (name
, ns
, &def_init
);
2362 def_init
->attr
.target
= 1;
2363 def_init
->attr
.artificial
= 1;
2364 def_init
->attr
.save
= SAVE_IMPLICIT
;
2365 def_init
->attr
.access
= ACCESS_PUBLIC
;
2366 def_init
->attr
.flavor
= FL_VARIABLE
;
2367 gfc_set_sym_referenced (def_init
);
2368 def_init
->ts
.type
= BT_DERIVED
;
2369 def_init
->ts
.u
.derived
= derived
;
2370 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2372 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2375 /* Add component _copy. */
2376 if (!gfc_add_component (vtype
, "_copy", &c
))
2378 c
->attr
.proc_pointer
= 1;
2379 c
->attr
.access
= ACCESS_PRIVATE
;
2380 c
->tb
= XCNEW (gfc_typebound_proc
);
2382 if (derived
->attr
.unlimited_polymorphic
2383 || derived
->attr
.abstract
)
2384 c
->initializer
= gfc_get_null_expr (NULL
);
2387 /* Set up namespace. */
2388 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2389 sub_ns
->sibling
= ns
->contained
;
2390 ns
->contained
= sub_ns
;
2391 sub_ns
->resolved
= 1;
2392 /* Set up procedure symbol. */
2393 sprintf (name
, "__copy_%s", tname
);
2394 gfc_get_symbol (name
, sub_ns
, ©
);
2395 sub_ns
->proc_name
= copy
;
2396 copy
->attr
.flavor
= FL_PROCEDURE
;
2397 copy
->attr
.subroutine
= 1;
2398 copy
->attr
.pure
= 1;
2399 copy
->attr
.artificial
= 1;
2400 copy
->attr
.if_source
= IFSRC_DECL
;
2401 /* This is elemental so that arrays are automatically
2402 treated correctly by the scalarizer. */
2403 copy
->attr
.elemental
= 1;
2404 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2405 copy
->module
= ns
->proc_name
->name
;
2406 gfc_set_sym_referenced (copy
);
2407 /* Set up formal arguments. */
2408 gfc_get_symbol ("src", sub_ns
, &src
);
2409 src
->ts
.type
= BT_DERIVED
;
2410 src
->ts
.u
.derived
= derived
;
2411 src
->attr
.flavor
= FL_VARIABLE
;
2412 src
->attr
.dummy
= 1;
2413 src
->attr
.artificial
= 1;
2414 src
->attr
.intent
= INTENT_IN
;
2415 gfc_set_sym_referenced (src
);
2416 copy
->formal
= gfc_get_formal_arglist ();
2417 copy
->formal
->sym
= src
;
2418 gfc_get_symbol ("dst", sub_ns
, &dst
);
2419 dst
->ts
.type
= BT_DERIVED
;
2420 dst
->ts
.u
.derived
= derived
;
2421 dst
->attr
.flavor
= FL_VARIABLE
;
2422 dst
->attr
.dummy
= 1;
2423 dst
->attr
.artificial
= 1;
2424 dst
->attr
.intent
= INTENT_INOUT
;
2425 gfc_set_sym_referenced (dst
);
2426 copy
->formal
->next
= gfc_get_formal_arglist ();
2427 copy
->formal
->next
->sym
= dst
;
2429 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2430 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2431 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2432 /* Set initializer. */
2433 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2434 c
->ts
.interface
= copy
;
2437 /* Add component _final, which contains a procedure pointer to
2438 a wrapper which handles both the freeing of allocatable
2439 components and the calls to finalization subroutines.
2440 Note: The actual wrapper function can only be generated
2441 at resolution time. */
2442 if (!gfc_add_component (vtype
, "_final", &c
))
2444 c
->attr
.proc_pointer
= 1;
2445 c
->attr
.access
= ACCESS_PRIVATE
;
2446 c
->tb
= XCNEW (gfc_typebound_proc
);
2448 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2450 /* Add component _deallocate. */
2451 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2453 c
->attr
.proc_pointer
= 1;
2454 c
->attr
.access
= ACCESS_PRIVATE
;
2455 c
->tb
= XCNEW (gfc_typebound_proc
);
2457 if (derived
->attr
.unlimited_polymorphic
2458 || derived
->attr
.abstract
2460 c
->initializer
= gfc_get_null_expr (NULL
);
2463 /* Set up namespace. */
2464 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2466 sub_ns
->sibling
= ns
->contained
;
2467 ns
->contained
= sub_ns
;
2468 sub_ns
->resolved
= 1;
2469 /* Set up procedure symbol. */
2470 sprintf (name
, "__deallocate_%s", tname
);
2471 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2472 sub_ns
->proc_name
= dealloc
;
2473 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2474 dealloc
->attr
.subroutine
= 1;
2475 dealloc
->attr
.pure
= 1;
2476 dealloc
->attr
.artificial
= 1;
2477 dealloc
->attr
.if_source
= IFSRC_DECL
;
2479 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2480 dealloc
->module
= ns
->proc_name
->name
;
2481 gfc_set_sym_referenced (dealloc
);
2482 /* Set up formal argument. */
2483 gfc_get_symbol ("arg", sub_ns
, &arg
);
2484 arg
->ts
.type
= BT_DERIVED
;
2485 arg
->ts
.u
.derived
= derived
;
2486 arg
->attr
.flavor
= FL_VARIABLE
;
2487 arg
->attr
.dummy
= 1;
2488 arg
->attr
.artificial
= 1;
2489 arg
->attr
.intent
= INTENT_INOUT
;
2490 arg
->attr
.dimension
= 1;
2491 arg
->attr
.allocatable
= 1;
2492 arg
->as
= gfc_get_array_spec();
2493 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2495 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2497 gfc_set_sym_referenced (arg
);
2498 dealloc
->formal
= gfc_get_formal_arglist ();
2499 dealloc
->formal
->sym
= arg
;
2501 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2502 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2503 sub_ns
->code
->ext
.alloc
.list
->expr
2504 = gfc_lval_expr_from_sym (arg
);
2505 /* Set initializer. */
2506 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2507 c
->ts
.interface
= dealloc
;
2510 /* Add procedure pointers for type-bound procedures. */
2511 if (!derived
->attr
.unlimited_polymorphic
)
2512 add_procs_to_declared_vtab (derived
, vtype
);
2516 vtab
->ts
.u
.derived
= vtype
;
2517 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2524 /* It is unexpected to have some symbols added at resolution or code
2525 generation time. We commit the changes in order to keep a clean state. */
2528 gfc_commit_symbol (vtab
);
2530 gfc_commit_symbol (vtype
);
2532 gfc_commit_symbol (def_init
);
2534 gfc_commit_symbol (copy
);
2536 gfc_commit_symbol (src
);
2538 gfc_commit_symbol (dst
);
2540 gfc_commit_symbol (dealloc
);
2542 gfc_commit_symbol (arg
);
2545 gfc_undo_symbols ();
2551 /* Check if a derived type is finalizable. That is the case if it
2552 (1) has a FINAL subroutine or
2553 (2) has a nonpointer nonallocatable component of finalizable type.
2554 If it is finalizable, return an expression containing the
2555 finalization wrapper. */
2558 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2563 /* (1) Check for FINAL subroutines. */
2564 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2567 /* (2) Check for components of finalizable type. */
2568 for (c
= derived
->components
; c
; c
= c
->next
)
2569 if (c
->ts
.type
== BT_DERIVED
2570 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2571 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2577 /* Make sure vtab is generated. */
2578 vtab
= gfc_find_derived_vtab (derived
);
2581 /* Return finalizer expression. */
2582 gfc_component
*final
;
2583 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2584 gcc_assert (strcmp (final
->name
, "_final") == 0);
2585 gcc_assert (final
->initializer
2586 && final
->initializer
->expr_type
!= EXPR_NULL
);
2587 *final_expr
= final
->initializer
;
2593 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2594 needed to support unlimited polymorphism. */
2597 find_intrinsic_vtab (gfc_typespec
*ts
)
2600 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2601 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2603 /* Find the top-level namespace. */
2604 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2610 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2612 /* Encode all types as TYPENAME_KIND_ including especially character
2613 arrays, whose length is now consistently stored in the _len component
2614 of the class-variable. */
2615 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2616 sprintf (name
, "__vtab_%s", tname
);
2618 /* Look for the vtab symbol in the top-level namespace only. */
2619 gfc_find_symbol (name
, ns
, 0, &vtab
);
2623 gfc_get_symbol (name
, ns
, &vtab
);
2624 vtab
->ts
.type
= BT_DERIVED
;
2625 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2626 &gfc_current_locus
))
2628 vtab
->attr
.target
= 1;
2629 vtab
->attr
.save
= SAVE_IMPLICIT
;
2630 vtab
->attr
.vtab
= 1;
2631 vtab
->attr
.access
= ACCESS_PUBLIC
;
2632 gfc_set_sym_referenced (vtab
);
2633 sprintf (name
, "__vtype_%s", tname
);
2635 gfc_find_symbol (name
, ns
, 0, &vtype
);
2640 gfc_namespace
*sub_ns
;
2641 gfc_namespace
*contained
;
2644 gfc_get_symbol (name
, ns
, &vtype
);
2645 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2646 &gfc_current_locus
))
2648 vtype
->attr
.access
= ACCESS_PUBLIC
;
2649 vtype
->attr
.vtype
= 1;
2650 gfc_set_sym_referenced (vtype
);
2652 /* Add component '_hash'. */
2653 if (!gfc_add_component (vtype
, "_hash", &c
))
2655 c
->ts
.type
= BT_INTEGER
;
2657 c
->attr
.access
= ACCESS_PRIVATE
;
2658 hash
= gfc_intrinsic_hash_value (ts
);
2659 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2662 /* Add component '_size'. */
2663 if (!gfc_add_component (vtype
, "_size", &c
))
2665 c
->ts
.type
= BT_INTEGER
;
2667 c
->attr
.access
= ACCESS_PRIVATE
;
2669 /* Build a minimal expression to make use of
2670 target-memory.c/gfc_element_size for 'size'. Special handling
2671 for character arrays, that are not constant sized: to support
2672 len (str) * kind, only the kind information is stored in the
2674 e
= gfc_get_expr ();
2676 e
->expr_type
= EXPR_VARIABLE
;
2677 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2679 ts
->type
== BT_CHARACTER
2681 : (int)gfc_element_size (e
));
2684 /* Add component _extends. */
2685 if (!gfc_add_component (vtype
, "_extends", &c
))
2687 c
->attr
.pointer
= 1;
2688 c
->attr
.access
= ACCESS_PRIVATE
;
2689 c
->ts
.type
= BT_VOID
;
2690 c
->initializer
= gfc_get_null_expr (NULL
);
2692 /* Add component _def_init. */
2693 if (!gfc_add_component (vtype
, "_def_init", &c
))
2695 c
->attr
.pointer
= 1;
2696 c
->attr
.access
= ACCESS_PRIVATE
;
2697 c
->ts
.type
= BT_VOID
;
2698 c
->initializer
= gfc_get_null_expr (NULL
);
2700 /* Add component _copy. */
2701 if (!gfc_add_component (vtype
, "_copy", &c
))
2703 c
->attr
.proc_pointer
= 1;
2704 c
->attr
.access
= ACCESS_PRIVATE
;
2705 c
->tb
= XCNEW (gfc_typebound_proc
);
2708 if (ts
->type
!= BT_CHARACTER
)
2709 sprintf (name
, "__copy_%s", tname
);
2712 /* __copy is always the same for characters.
2713 Check to see if copy function already exists. */
2714 sprintf (name
, "__copy_character_%d", ts
->kind
);
2715 contained
= ns
->contained
;
2716 for (; contained
; contained
= contained
->sibling
)
2717 if (contained
->proc_name
2718 && strcmp (name
, contained
->proc_name
->name
) == 0)
2720 copy
= contained
->proc_name
;
2725 /* Set up namespace. */
2726 sub_ns
= gfc_get_namespace (ns
, 0);
2727 sub_ns
->sibling
= ns
->contained
;
2728 ns
->contained
= sub_ns
;
2729 sub_ns
->resolved
= 1;
2730 /* Set up procedure symbol. */
2731 gfc_get_symbol (name
, sub_ns
, ©
);
2732 sub_ns
->proc_name
= copy
;
2733 copy
->attr
.flavor
= FL_PROCEDURE
;
2734 copy
->attr
.subroutine
= 1;
2735 copy
->attr
.pure
= 1;
2736 copy
->attr
.if_source
= IFSRC_DECL
;
2737 /* This is elemental so that arrays are automatically
2738 treated correctly by the scalarizer. */
2739 copy
->attr
.elemental
= 1;
2740 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2741 copy
->module
= ns
->proc_name
->name
;
2742 gfc_set_sym_referenced (copy
);
2743 /* Set up formal arguments. */
2744 gfc_get_symbol ("src", sub_ns
, &src
);
2745 src
->ts
.type
= ts
->type
;
2746 src
->ts
.kind
= ts
->kind
;
2747 src
->attr
.flavor
= FL_VARIABLE
;
2748 src
->attr
.dummy
= 1;
2749 src
->attr
.intent
= INTENT_IN
;
2750 gfc_set_sym_referenced (src
);
2751 copy
->formal
= gfc_get_formal_arglist ();
2752 copy
->formal
->sym
= src
;
2753 gfc_get_symbol ("dst", sub_ns
, &dst
);
2754 dst
->ts
.type
= ts
->type
;
2755 dst
->ts
.kind
= ts
->kind
;
2756 dst
->attr
.flavor
= FL_VARIABLE
;
2757 dst
->attr
.dummy
= 1;
2758 dst
->attr
.intent
= INTENT_INOUT
;
2759 gfc_set_sym_referenced (dst
);
2760 copy
->formal
->next
= gfc_get_formal_arglist ();
2761 copy
->formal
->next
->sym
= dst
;
2763 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2764 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2765 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2767 /* Set initializer. */
2768 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2769 c
->ts
.interface
= copy
;
2771 /* Add component _final. */
2772 if (!gfc_add_component (vtype
, "_final", &c
))
2774 c
->attr
.proc_pointer
= 1;
2775 c
->attr
.access
= ACCESS_PRIVATE
;
2776 c
->tb
= XCNEW (gfc_typebound_proc
);
2778 c
->initializer
= gfc_get_null_expr (NULL
);
2780 vtab
->ts
.u
.derived
= vtype
;
2781 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2788 /* It is unexpected to have some symbols added at resolution or code
2789 generation time. We commit the changes in order to keep a clean state. */
2792 gfc_commit_symbol (vtab
);
2794 gfc_commit_symbol (vtype
);
2796 gfc_commit_symbol (copy
);
2798 gfc_commit_symbol (src
);
2800 gfc_commit_symbol (dst
);
2803 gfc_undo_symbols ();
2809 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2812 gfc_find_vtab (gfc_typespec
*ts
)
2819 return gfc_find_derived_vtab (ts
->u
.derived
);
2821 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2823 return find_intrinsic_vtab (ts
);
2828 /* General worker function to find either a type-bound procedure or a
2829 type-bound user operator. */
2832 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2833 const char* name
, bool noaccess
, bool uop
,
2839 /* Set default to failure. */
2843 if (derived
->f2k_derived
)
2844 /* Set correct symbol-root. */
2845 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2846 : derived
->f2k_derived
->tb_sym_root
);
2850 /* Try to find it in the current type's namespace. */
2851 res
= gfc_find_symtree (root
, name
);
2852 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2858 if (!noaccess
&& derived
->attr
.use_assoc
2859 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2862 gfc_error ("%qs of %qs is PRIVATE at %L",
2863 name
, derived
->name
, where
);
2871 /* Otherwise, recurse on parent type if derived is an extension. */
2872 if (derived
->attr
.extension
)
2874 gfc_symbol
* super_type
;
2875 super_type
= gfc_get_derived_super_type (derived
);
2876 gcc_assert (super_type
);
2878 return find_typebound_proc_uop (super_type
, t
, name
,
2879 noaccess
, uop
, where
);
2882 /* Nothing found. */
2887 /* Find a type-bound procedure or user operator by name for a derived-type
2888 (looking recursively through the super-types). */
2891 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2892 const char* name
, bool noaccess
, locus
* where
)
2894 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2898 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2899 const char* name
, bool noaccess
, locus
* where
)
2901 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2905 /* Find a type-bound intrinsic operator looking recursively through the
2906 super-type hierarchy. */
2909 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2910 gfc_intrinsic_op op
, bool noaccess
,
2913 gfc_typebound_proc
* res
;
2915 /* Set default to failure. */
2919 /* Try to find it in the current type's namespace. */
2920 if (derived
->f2k_derived
)
2921 res
= derived
->f2k_derived
->tb_op
[op
];
2926 if (res
&& !res
->error
)
2932 if (!noaccess
&& derived
->attr
.use_assoc
2933 && res
->access
== ACCESS_PRIVATE
)
2936 gfc_error ("%qs of %qs is PRIVATE at %L",
2937 gfc_op2string (op
), derived
->name
, where
);
2945 /* Otherwise, recurse on parent type if derived is an extension. */
2946 if (derived
->attr
.extension
)
2948 gfc_symbol
* super_type
;
2949 super_type
= gfc_get_derived_super_type (derived
);
2950 gcc_assert (super_type
);
2952 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2956 /* Nothing found. */
2961 /* Get a typebound-procedure symtree or create and insert it if not yet
2962 present. This is like a very simplified version of gfc_get_sym_tree for
2963 tbp-symtrees rather than regular ones. */
2966 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2968 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
2969 return result
? result
: gfc_new_symtree (root
, name
);