1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2013 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 For each derived type we set up a "vtable" entry, i.e. a structure with the
39 * _hash: A hash value serving as a unique identifier for this type.
40 * _size: The size in bytes of the derived type.
41 * _extends: A pointer to the vtable entry of the parent derived type.
42 * _def_init: A pointer to a default initialized variable of this type.
43 * _copy: A procedure pointer to a copying procedure.
44 * _final: A procedure pointer to a wrapper function, which frees
45 allocatable components and calls FINAL subroutines.
47 After these follow procedure pointer components for the specific
48 type-bound procedures. */
53 #include "coretypes.h"
55 #include "constructor.h"
57 /* Inserts a derived type component reference in a data reference chain.
58 TS: base type of the ref chain so far, in which we will pick the component
59 REF: the address of the GFC_REF pointer to update
60 NAME: name of the component to insert
61 Note that component insertion makes sense only if we are at the end of
62 the chain (*REF == NULL) or if we are adding a missing "_data" component
63 to access the actual contents of a class object. */
66 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
71 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
72 type_sym
= ts
->u
.derived
;
74 new_ref
= gfc_get_ref ();
75 new_ref
->type
= REF_COMPONENT
;
77 new_ref
->u
.c
.sym
= type_sym
;
78 new_ref
->u
.c
.component
= gfc_find_component (type_sym
, name
, true, true);
79 gcc_assert (new_ref
->u
.c
.component
);
85 /* We need to update the base type in the trailing reference chain to
86 that of the new component. */
88 gcc_assert (strcmp (name
, "_data") == 0);
90 if (new_ref
->next
->type
== REF_COMPONENT
)
92 else if (new_ref
->next
->type
== REF_ARRAY
93 && new_ref
->next
->next
94 && new_ref
->next
->next
->type
== REF_COMPONENT
)
95 next
= new_ref
->next
->next
;
99 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
100 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
101 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
109 /* Tells whether we need to add a "_data" reference to access REF subobject
110 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
111 object accessed by REF is a variable; in other words it is a full object,
115 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
117 /* Only class containers may need the "_data" reference. */
118 if (ts
->type
!= BT_CLASS
)
121 /* Accessing a class container with an array reference is certainly wrong. */
122 if (ref
->type
!= REF_COMPONENT
)
125 /* Accessing the class container's fields is fine. */
126 if (ref
->u
.c
.component
->name
[0] == '_')
129 /* At this point we have a class container with a non class container's field
130 component reference. We don't want to add the "_data" component if we are
131 at the first reference and the symbol's type is an extended derived type.
132 In that case, conv_parent_component_references will do the right thing so
133 it is not absolutely necessary. Omitting it prevents a regression (see
134 class_41.f03) in the interface mapping mechanism. When evaluating string
135 lengths depending on dummy arguments, we create a fake symbol with a type
136 equal to that of the dummy type. However, because of type extension,
137 the backend type (corresponding to the actual argument) can have a
138 different (extended) type. Adding the "_data" component explicitly, using
139 the base type, confuses the gfc_conv_component_ref code which deals with
140 the extended type. */
141 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
144 /* We have a class container with a non class container's field component
145 reference that doesn't fall into the above. */
150 /* Browse through a data reference chain and add the missing "_data" references
151 when a subobject of a class object is accessed without it.
152 Note that it doesn't add the "_data" reference when the class container
153 is the last element in the reference chain. */
156 gfc_fix_class_refs (gfc_expr
*e
)
161 if ((e
->expr_type
!= EXPR_VARIABLE
162 && e
->expr_type
!= EXPR_FUNCTION
)
163 || (e
->expr_type
== EXPR_FUNCTION
164 && e
->value
.function
.isym
!= NULL
))
167 if (e
->expr_type
== EXPR_VARIABLE
)
168 ts
= &e
->symtree
->n
.sym
->ts
;
173 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
174 if (e
->value
.function
.esym
!= NULL
)
175 func
= e
->value
.function
.esym
;
177 func
= e
->symtree
->n
.sym
;
179 if (func
->result
!= NULL
)
180 ts
= &func
->result
->ts
;
185 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
187 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
188 insert_component_ref (ts
, ref
, "_data");
190 if ((*ref
)->type
== REF_COMPONENT
)
191 ts
= &(*ref
)->u
.c
.component
->ts
;
196 /* Insert a reference to the component of the given name.
197 Only to be used with CLASS containers and vtables. */
200 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
202 gfc_ref
**tail
= &(e
->ref
);
203 gfc_ref
*next
= NULL
;
204 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
205 while (*tail
!= NULL
)
207 if ((*tail
)->type
== REF_COMPONENT
)
209 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
211 && (*tail
)->next
->type
== REF_ARRAY
212 && (*tail
)->next
->next
== NULL
)
214 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
216 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
218 tail
= &((*tail
)->next
);
220 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
222 (*tail
) = gfc_get_ref();
223 (*tail
)->next
= next
;
224 (*tail
)->type
= REF_COMPONENT
;
225 (*tail
)->u
.c
.sym
= derived
;
226 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
227 gcc_assert((*tail
)->u
.c
.component
);
229 e
->ts
= (*tail
)->u
.c
.component
->ts
;
233 /* This is used to add both the _data component reference and an array
234 reference to class expressions. Used in translation of intrinsic
235 array inquiry functions. */
238 gfc_add_class_array_ref (gfc_expr
*e
)
240 int rank
= CLASS_DATA (e
)->as
->rank
;
241 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
243 gfc_add_component_ref (e
, "_data");
245 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
248 if (ref
->type
!= REF_ARRAY
)
250 ref
->next
= gfc_get_ref ();
252 ref
->type
= REF_ARRAY
;
253 ref
->u
.ar
.type
= AR_FULL
;
259 /* Unfortunately, class array expressions can appear in various conditions;
260 with and without both _data component and an arrayspec. This function
261 deals with that variability. The previous reference to 'ref' is to a
265 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
267 bool no_data
= false;
268 bool with_data
= false;
270 /* An array reference with no _data component. */
271 if (ref
&& ref
->type
== REF_ARRAY
273 && ref
->u
.ar
.type
!= AR_ELEMENT
)
276 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
280 /* Cover cases where _data appears, with or without an array ref. */
281 if (ref
&& ref
->type
== REF_COMPONENT
282 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
290 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
292 && ref
->type
== REF_COMPONENT
293 && ref
->next
->type
== REF_ARRAY
294 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
298 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
302 return no_data
|| with_data
;
306 /* Returns true if the expression contains a reference to a class
307 array. Notice that class array elements return false. */
310 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
320 /* Is this a class array object? ie. Is the symbol of type class? */
322 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
323 && CLASS_DATA (e
->symtree
->n
.sym
)
324 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
325 && class_array_ref_detected (e
->ref
, full_array
))
328 /* Or is this a class array component reference? */
329 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
331 if (ref
->type
== REF_COMPONENT
332 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
333 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
334 && class_array_ref_detected (ref
->next
, full_array
))
342 /* Returns true if the expression is a reference to a class
343 scalar. This function is necessary because such expressions
344 can be dressed with a reference to the _data component and so
345 have a type other than BT_CLASS. */
348 gfc_is_class_scalar_expr (gfc_expr
*e
)
355 /* Is this a class object? */
357 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
358 && CLASS_DATA (e
->symtree
->n
.sym
)
359 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
361 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
362 && e
->ref
->next
== NULL
)))
365 /* Or is the final reference BT_CLASS or _data? */
366 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
370 && CLASS_DATA (ref
->u
.c
.component
)
371 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
372 && (ref
->next
== NULL
373 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
374 && ref
->next
->next
== NULL
)))
382 /* Tells whether the expression E is a reference to a (scalar) class container.
383 Scalar because array class containers usually have an array reference after
384 them, and gfc_fix_class_refs will add the missing "_data" component reference
388 gfc_is_class_container_ref (gfc_expr
*e
)
393 if (e
->expr_type
!= EXPR_VARIABLE
)
394 return e
->ts
.type
== BT_CLASS
;
396 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
401 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
403 if (ref
->type
!= REF_COMPONENT
)
405 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
415 /* Build an initializer for CLASS pointers,
416 initializing the _data component to the init_expr (or NULL) and the _vptr
417 component to the corresponding type (or the declared type, given by ts). */
420 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
424 gfc_symbol
*vtab
= NULL
;
425 bool is_unlimited_polymorphic
;
427 is_unlimited_polymorphic
= ts
->u
.derived
428 && ts
->u
.derived
->components
->ts
.u
.derived
429 && ts
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
;
431 if (is_unlimited_polymorphic
&& init_expr
)
432 vtab
= gfc_find_intrinsic_vtab (&ts
->u
.derived
->components
->ts
);
433 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
434 vtab
= gfc_find_derived_vtab (init_expr
->ts
.u
.derived
);
436 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
438 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
439 &ts
->u
.derived
->declared_at
);
442 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
444 gfc_constructor
*ctor
= gfc_constructor_get();
445 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
446 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
447 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
448 ctor
->expr
= gfc_copy_expr (init_expr
);
450 ctor
->expr
= gfc_get_null_expr (NULL
);
451 gfc_constructor_append (&init
->value
.constructor
, ctor
);
458 /* Create a unique string identifier for a derived type, composed of its name
459 and module name. This is used to construct unique names for the class
460 containers and vtab symbols. */
463 get_unique_type_string (char *string
, gfc_symbol
*derived
)
465 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
466 if (derived
->attr
.unlimited_polymorphic
)
467 strcpy (dt_name
, "STAR");
469 strcpy (dt_name
, derived
->name
);
470 dt_name
[0] = TOUPPER (dt_name
[0]);
471 if (derived
->attr
.unlimited_polymorphic
)
472 sprintf (string
, "_%s", dt_name
);
473 else if (derived
->module
)
474 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
475 else if (derived
->ns
->proc_name
)
476 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
478 sprintf (string
, "_%s", dt_name
);
482 /* A relative of 'get_unique_type_string' which makes sure the generated
483 string will not be too long (replacing it by a hash string if needed). */
486 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
488 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
489 get_unique_type_string (&tmp
[0], derived
);
490 /* If string is too long, use hash value in hex representation (allow for
491 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
492 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
493 where %d is the (co)rank which can be up to n = 15. */
494 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
496 int h
= gfc_hash_value (derived
);
497 sprintf (string
, "%X", h
);
500 strcpy (string
, tmp
);
504 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
507 gfc_hash_value (gfc_symbol
*sym
)
509 unsigned int hash
= 0;
510 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
513 get_unique_type_string (&c
[0], sym
);
516 for (i
= 0; i
< len
; i
++)
517 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
519 /* Return the hash but take the modulus for the sake of module read,
520 even though this slightly increases the chance of collision. */
521 return (hash
% 100000000);
525 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
528 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
530 unsigned int hash
= 0;
531 const char *c
= gfc_typename (ts
);
536 for (i
= 0; i
< len
; i
++)
537 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
539 /* Return the hash but take the modulus for the sake of module read,
540 even though this slightly increases the chance of collision. */
541 return (hash
% 100000000);
545 /* Build a polymorphic CLASS entity, using the symbol that comes from
546 build_sym. A CLASS entity is represented by an encapsulating type,
547 which contains the declared type as '_data' component, plus a pointer
548 component '_vptr' which determines the dynamic type. */
551 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
552 gfc_array_spec
**as
, bool delayed_vtab
)
554 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
563 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
565 gfc_error ("Assumed size polymorphic objects or components, such "
566 "as that at %C, have not yet been implemented");
571 /* Class container has already been built. */
574 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
575 || attr
->select_type_temporary
|| attr
->associate_var
;
578 /* We can not build the class container yet. */
581 /* Determine the name of the encapsulating type. */
582 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
583 get_unique_hashed_string (tname
, ts
->u
.derived
);
584 if ((*as
) && attr
->allocatable
)
585 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
586 else if ((*as
) && attr
->pointer
)
587 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
589 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
590 else if (attr
->pointer
)
591 sprintf (name
, "__class_%s_p", tname
);
592 else if (attr
->allocatable
)
593 sprintf (name
, "__class_%s_a", tname
);
595 sprintf (name
, "__class_%s", tname
);
597 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
599 /* Find the top-level namespace. */
600 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
605 ns
= ts
->u
.derived
->ns
;
607 gfc_find_symbol (name
, ns
, 0, &fclass
);
611 /* If not there, create a new symbol. */
612 fclass
= gfc_new_symbol (name
, ns
);
613 st
= gfc_new_symtree (&ns
->sym_root
, name
);
615 gfc_set_sym_referenced (fclass
);
617 fclass
->ts
.type
= BT_UNKNOWN
;
618 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
619 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
620 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
621 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
625 /* Add component '_data'. */
626 if (!gfc_add_component (fclass
, "_data", &c
))
629 c
->ts
.type
= BT_DERIVED
;
630 c
->attr
.access
= ACCESS_PRIVATE
;
631 c
->ts
.u
.derived
= ts
->u
.derived
;
632 c
->attr
.class_pointer
= attr
->pointer
;
633 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
634 || attr
->select_type_temporary
;
635 c
->attr
.allocatable
= attr
->allocatable
;
636 c
->attr
.dimension
= attr
->dimension
;
637 c
->attr
.codimension
= attr
->codimension
;
638 c
->attr
.abstract
= fclass
->attr
.abstract
;
640 c
->initializer
= NULL
;
642 /* Add component '_vptr'. */
643 if (!gfc_add_component (fclass
, "_vptr", &c
))
645 c
->ts
.type
= BT_DERIVED
;
647 || (ts
->u
.derived
->f2k_derived
648 && ts
->u
.derived
->f2k_derived
->finalizers
))
649 c
->ts
.u
.derived
= NULL
;
652 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
654 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
656 c
->attr
.access
= ACCESS_PRIVATE
;
660 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
662 /* Since the extension field is 8 bit wide, we can only have
663 up to 255 extension levels. */
664 if (ts
->u
.derived
->attr
.extension
== 255)
666 gfc_error ("Maximum extension level reached with type '%s' at %L",
667 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
671 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
672 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
673 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
676 fclass
->attr
.is_class
= 1;
677 ts
->u
.derived
= fclass
;
678 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
684 /* Add a procedure pointer component to the vtype
685 to represent a specific type-bound procedure. */
688 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
692 if (tb
->non_overridable
)
695 c
= gfc_find_component (vtype
, name
, true, true);
699 /* Add procedure component. */
700 if (!gfc_add_component (vtype
, name
, &c
))
704 c
->tb
= XCNEW (gfc_typebound_proc
);
707 c
->attr
.procedure
= 1;
708 c
->attr
.proc_pointer
= 1;
709 c
->attr
.flavor
= FL_PROCEDURE
;
710 c
->attr
.access
= ACCESS_PRIVATE
;
711 c
->attr
.external
= 1;
713 c
->attr
.if_source
= IFSRC_IFBODY
;
715 else if (c
->attr
.proc_pointer
&& c
->tb
)
723 c
->ts
.interface
= tb
->u
.specific
->n
.sym
;
725 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
730 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
733 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
739 add_procs_to_declared_vtab1 (st
->left
, vtype
);
742 add_procs_to_declared_vtab1 (st
->right
, vtype
);
744 if (st
->n
.tb
&& !st
->n
.tb
->error
745 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
746 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
750 /* Copy procedure pointers components from the parent type. */
753 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
758 vtab
= gfc_find_derived_vtab (declared
);
760 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
762 if (gfc_find_component (vtype
, cmp
->name
, true, true))
765 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
770 /* Returns true if any of its nonpointer nonallocatable components or
771 their nonpointer nonallocatable subcomponents has a finalization
775 has_finalizer_component (gfc_symbol
*derived
)
779 for (c
= derived
->components
; c
; c
= c
->next
)
781 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
782 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
785 if (c
->ts
.type
== BT_DERIVED
786 && !c
->attr
.pointer
&& !c
->attr
.allocatable
787 && has_finalizer_component (c
->ts
.u
.derived
))
794 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
795 neither allocatable nor a pointer but has a finalizer, call it. If it
796 is a nonpointer component with allocatable components or has finalizers, walk
797 them. Either of them is required; other nonallocatables and pointers aren't
799 Note: If the component is allocatable, the DEALLOCATE handling takes care
800 of calling the appropriate finalizers, coarray deregistering, and
801 deallocation of allocatable subcomponents. */
804 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
805 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
)
810 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
811 && !comp
->attr
.allocatable
)
814 if ((comp
->ts
.type
== BT_DERIVED
&& comp
->attr
.pointer
)
815 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
816 && CLASS_DATA (comp
)->attr
.pointer
))
819 if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.allocatable
820 && (comp
->ts
.u
.derived
->f2k_derived
== NULL
821 || comp
->ts
.u
.derived
->f2k_derived
->finalizers
== NULL
)
822 && !has_finalizer_component (comp
->ts
.u
.derived
))
825 e
= gfc_copy_expr (expr
);
827 e
->ref
= ref
= gfc_get_ref ();
830 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
832 ref
->next
= gfc_get_ref ();
835 ref
->type
= REF_COMPONENT
;
836 ref
->u
.c
.sym
= derived
;
837 ref
->u
.c
.component
= comp
;
840 if (comp
->attr
.dimension
|| comp
->attr
.codimension
841 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
842 && (CLASS_DATA (comp
)->attr
.dimension
843 || CLASS_DATA (comp
)->attr
.codimension
)))
845 ref
->next
= gfc_get_ref ();
846 ref
->next
->type
= REF_ARRAY
;
847 ref
->next
->u
.ar
.dimen
= 0;
848 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
850 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
851 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
854 /* Call DEALLOCATE (comp, stat=ignore). */
855 if (comp
->attr
.allocatable
856 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
857 && CLASS_DATA (comp
)->attr
.allocatable
))
859 gfc_code
*dealloc
, *block
= NULL
;
861 /* Add IF (fini_coarray). */
862 if (comp
->attr
.codimension
863 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
864 && CLASS_DATA (comp
)->attr
.allocatable
))
866 block
= XCNEW (gfc_code
);
869 (*code
)->next
= block
;
870 (*code
) = (*code
)->next
;
875 block
->loc
= gfc_current_locus
;
878 block
->block
= XCNEW (gfc_code
);
879 block
= block
->block
;
880 block
->loc
= gfc_current_locus
;
882 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
885 dealloc
= XCNEW (gfc_code
);
886 dealloc
->op
= EXEC_DEALLOCATE
;
887 dealloc
->loc
= gfc_current_locus
;
889 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
890 dealloc
->ext
.alloc
.list
->expr
= e
;
891 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
894 block
->next
= dealloc
;
897 (*code
)->next
= dealloc
;
898 (*code
) = (*code
)->next
;
903 else if (comp
->ts
.type
== BT_DERIVED
904 && comp
->ts
.u
.derived
->f2k_derived
905 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
907 /* Call FINAL_WRAPPER (comp); */
908 gfc_code
*final_wrap
;
912 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
913 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
914 if (strcmp (c
->name
, "_final") == 0)
918 final_wrap
= XCNEW (gfc_code
);
919 final_wrap
->op
= EXEC_CALL
;
920 final_wrap
->loc
= gfc_current_locus
;
921 final_wrap
->loc
= gfc_current_locus
;
922 final_wrap
->symtree
= c
->initializer
->symtree
;
923 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
924 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
925 final_wrap
->ext
.actual
->expr
= e
;
929 (*code
)->next
= final_wrap
;
930 (*code
) = (*code
)->next
;
933 (*code
) = final_wrap
;
939 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
940 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
946 /* Generate code equivalent to
947 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
948 + offset, c_ptr), ptr). */
951 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
952 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
955 gfc_expr
*expr
, *expr2
;
958 block
= XCNEW (gfc_code
);
959 block
->op
= EXEC_CALL
;
960 block
->loc
= gfc_current_locus
;
961 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
962 block
->resolved_sym
= block
->symtree
->n
.sym
;
963 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
964 block
->resolved_sym
->attr
.intrinsic
= 1;
965 block
->resolved_sym
->attr
.subroutine
= 1;
966 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
967 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
968 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
969 gfc_commit_symbol (block
->resolved_sym
);
971 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
972 block
->ext
.actual
= gfc_get_actual_arglist ();
973 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
974 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
976 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
978 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
980 /* TRANSFER's first argument: C_LOC (array). */
981 expr
= gfc_get_expr ();
982 expr
->expr_type
= EXPR_FUNCTION
;
983 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
984 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
985 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
986 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
987 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
988 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
989 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
990 expr
->value
.function
.actual
->expr
991 = gfc_lval_expr_from_sym (array
);
992 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
993 gfc_commit_symbol (expr
->symtree
->n
.sym
);
994 expr
->ts
.type
= BT_INTEGER
;
995 expr
->ts
.kind
= gfc_index_integer_kind
;
998 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
999 gfc_current_locus
, 3, expr
,
1000 gfc_get_int_expr (gfc_index_integer_kind
,
1002 expr2
->ts
.type
= BT_INTEGER
;
1003 expr2
->ts
.kind
= gfc_index_integer_kind
;
1005 /* <array addr> + <offset>. */
1006 block
->ext
.actual
->expr
= gfc_get_expr ();
1007 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1008 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1009 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1010 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1011 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1013 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1014 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1015 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1016 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1022 /* Calculates the offset to the (idx+1)th element of an array, taking the
1023 stride into account. It generates the code:
1026 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1028 offset = offset * byte_stride. */
1031 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1032 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1033 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1034 gfc_code
*block
, gfc_namespace
*sub_ns
)
1037 gfc_expr
*expr
, *expr2
;
1040 block
->next
= XCNEW (gfc_code
);
1041 block
= block
->next
;
1042 block
->op
= EXEC_ASSIGN
;
1043 block
->loc
= gfc_current_locus
;
1044 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1045 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1048 iter
= gfc_get_iterator ();
1049 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1050 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1051 iter
->end
= gfc_copy_expr (rank
);
1052 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1053 block
->next
= XCNEW (gfc_code
);
1054 block
= block
->next
;
1055 block
->op
= EXEC_DO
;
1056 block
->loc
= gfc_current_locus
;
1057 block
->ext
.iterator
= iter
;
1058 block
->block
= gfc_get_code ();
1059 block
->block
->op
= EXEC_DO
;
1061 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1064 /* mod (idx, sizes(idx2)). */
1065 expr
= gfc_lval_expr_from_sym (sizes
);
1066 expr
->ref
= gfc_get_ref ();
1067 expr
->ref
->type
= REF_ARRAY
;
1068 expr
->ref
->u
.ar
.as
= sizes
->as
;
1069 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1070 expr
->ref
->u
.ar
.dimen
= 1;
1071 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1072 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1074 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1075 gfc_current_locus
, 2,
1076 gfc_lval_expr_from_sym (idx
), expr
);
1079 /* (...) / sizes(idx2-1). */
1080 expr2
= gfc_get_expr ();
1081 expr2
->expr_type
= EXPR_OP
;
1082 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1083 expr2
->value
.op
.op1
= expr
;
1084 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1085 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1086 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1087 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1088 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1089 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1090 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1091 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1092 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1093 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1094 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1095 = gfc_lval_expr_from_sym (idx2
);
1096 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1097 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1098 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1099 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1100 expr2
->ts
= idx
->ts
;
1102 /* ... * strides(idx2). */
1103 expr
= gfc_get_expr ();
1104 expr
->expr_type
= EXPR_OP
;
1105 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1106 expr
->value
.op
.op1
= expr2
;
1107 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1108 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1109 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1110 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1111 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1112 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1113 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1114 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1117 /* offset = offset + ... */
1118 block
->block
->next
= XCNEW (gfc_code
);
1119 block
->block
->next
->op
= EXEC_ASSIGN
;
1120 block
->block
->next
->loc
= gfc_current_locus
;
1121 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1122 block
->block
->next
->expr2
= gfc_get_expr ();
1123 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1124 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1125 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1126 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1127 block
->block
->next
->expr2
->ts
= idx
->ts
;
1129 /* After the loop: offset = offset * byte_stride. */
1130 block
->next
= XCNEW (gfc_code
);
1131 block
= block
->next
;
1132 block
->op
= EXEC_ASSIGN
;
1133 block
->loc
= gfc_current_locus
;
1134 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1135 block
->expr2
= gfc_get_expr ();
1136 block
->expr2
->expr_type
= EXPR_OP
;
1137 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1138 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1139 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1140 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1145 /* Insert code of the following form:
1148 integer(c_intptr_t) :: i
1150 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1151 && (is_contiguous || !final_rank3->attr.contiguous
1152 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1153 || 0 == STORAGE_SIZE (array)) then
1154 call final_rank3 (array)
1157 integer(c_intptr_t) :: offset, j
1158 type(t) :: tmp(shape (array))
1160 do i = 0, size (array)-1
1161 offset = obtain_offset(i, strides, sizes, byte_stride)
1162 addr = transfer (c_loc (array), addr) + offset
1163 call c_f_pointer (transfer (addr, cptr), ptr)
1165 addr = transfer (c_loc (tmp), addr)
1166 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1167 call c_f_pointer (transfer (addr, cptr), ptr2)
1170 call final_rank3 (tmp)
1176 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1177 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1178 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1180 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1181 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1182 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1183 gfc_namespace
*sub_ns
)
1185 gfc_symbol
*tmp_array
, *ptr2
;
1186 gfc_expr
*size_expr
, *offset2
, *expr
;
1192 block
->next
= XCNEW (gfc_code
);
1193 block
= block
->next
;
1194 block
->loc
= gfc_current_locus
;
1195 block
->op
= EXEC_IF
;
1197 block
->block
= XCNEW (gfc_code
);
1198 block
= block
->block
;
1199 block
->loc
= gfc_current_locus
;
1200 block
->op
= EXEC_IF
;
1202 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1203 size_expr
= gfc_get_expr ();
1204 size_expr
->where
= gfc_current_locus
;
1205 size_expr
->expr_type
= EXPR_OP
;
1206 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1208 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1209 size_expr
->value
.op
.op1
1210 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1211 "storage_size", gfc_current_locus
, 2,
1212 gfc_lval_expr_from_sym (array
),
1213 gfc_get_int_expr (gfc_index_integer_kind
,
1216 /* NUMERIC_STORAGE_SIZE. */
1217 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1218 gfc_character_storage_size
);
1219 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1220 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1222 /* IF condition: (stride == size_expr
1223 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1225 || 0 == size_expr. */
1226 block
->expr1
= gfc_get_expr ();
1227 block
->expr1
->ts
.type
= BT_LOGICAL
;
1228 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1229 block
->expr1
->expr_type
= EXPR_OP
;
1230 block
->expr1
->where
= gfc_current_locus
;
1232 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1234 /* byte_stride == size_expr */
1235 expr
= gfc_get_expr ();
1236 expr
->ts
.type
= BT_LOGICAL
;
1237 expr
->ts
.kind
= gfc_default_logical_kind
;
1238 expr
->expr_type
= EXPR_OP
;
1239 expr
->where
= gfc_current_locus
;
1240 expr
->value
.op
.op
= INTRINSIC_EQ
;
1242 = gfc_lval_expr_from_sym (byte_stride
);
1243 expr
->value
.op
.op2
= size_expr
;
1245 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1246 add is_contiguous check. */
1248 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1249 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1252 expr2
= gfc_get_expr ();
1253 expr2
->ts
.type
= BT_LOGICAL
;
1254 expr2
->ts
.kind
= gfc_default_logical_kind
;
1255 expr2
->expr_type
= EXPR_OP
;
1256 expr2
->where
= gfc_current_locus
;
1257 expr2
->value
.op
.op
= INTRINSIC_AND
;
1258 expr2
->value
.op
.op1
= expr
;
1259 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1263 block
->expr1
->value
.op
.op1
= expr
;
1265 /* 0 == size_expr */
1266 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1267 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1268 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1269 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1270 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1271 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1272 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1273 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1274 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1276 /* IF body: call final subroutine. */
1277 block
->next
= XCNEW (gfc_code
);
1278 block
->next
->op
= EXEC_CALL
;
1279 block
->next
->loc
= gfc_current_locus
;
1280 block
->next
->symtree
= fini
->proc_tree
;
1281 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1282 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1283 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1287 block
->block
= XCNEW (gfc_code
);
1288 block
= block
->block
;
1289 block
->loc
= gfc_current_locus
;
1290 block
->op
= EXEC_IF
;
1292 block
->next
= XCNEW (gfc_code
);
1293 block
= block
->next
;
1295 /* BLOCK ... END BLOCK. */
1296 block
->op
= EXEC_BLOCK
;
1297 block
->loc
= gfc_current_locus
;
1298 ns
= gfc_build_block_ns (sub_ns
);
1299 block
->ext
.block
.ns
= ns
;
1300 block
->ext
.block
.assoc
= NULL
;
1302 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1303 ptr2
->ts
.type
= BT_DERIVED
;
1304 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1305 ptr2
->attr
.flavor
= FL_VARIABLE
;
1306 ptr2
->attr
.pointer
= 1;
1307 ptr2
->attr
.artificial
= 1;
1308 gfc_set_sym_referenced (ptr2
);
1309 gfc_commit_symbol (ptr2
);
1311 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1312 tmp_array
->ts
.type
= BT_DERIVED
;
1313 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1314 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1315 tmp_array
->attr
.dimension
= 1;
1316 tmp_array
->attr
.artificial
= 1;
1317 tmp_array
->as
= gfc_get_array_spec();
1318 tmp_array
->attr
.intent
= INTENT_INOUT
;
1319 tmp_array
->as
->type
= AS_EXPLICIT
;
1320 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1322 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1324 gfc_expr
*shape_expr
;
1325 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1327 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1329 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1330 gfc_current_locus
, 3,
1331 gfc_lval_expr_from_sym (array
),
1332 gfc_get_int_expr (gfc_default_integer_kind
,
1334 gfc_get_int_expr (gfc_default_integer_kind
,
1336 gfc_index_integer_kind
));
1337 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1338 tmp_array
->as
->upper
[i
] = shape_expr
;
1340 gfc_set_sym_referenced (tmp_array
);
1341 gfc_commit_symbol (tmp_array
);
1344 iter
= gfc_get_iterator ();
1345 iter
->var
= gfc_lval_expr_from_sym (idx
);
1346 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1347 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1348 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1350 block
= XCNEW (gfc_code
);
1352 block
->op
= EXEC_DO
;
1353 block
->loc
= gfc_current_locus
;
1354 block
->ext
.iterator
= iter
;
1355 block
->block
= gfc_get_code ();
1356 block
->block
->op
= EXEC_DO
;
1358 /* Offset calculation for the new array: idx * size of type (in bytes). */
1359 offset2
= gfc_get_expr ();
1360 offset2
->expr_type
= EXPR_OP
;
1361 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1362 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1363 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1364 offset2
->ts
= byte_stride
->ts
;
1366 /* Offset calculation of "array". */
1367 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1368 byte_stride
, rank
, block
->block
, sub_ns
);
1371 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1372 + idx * stride, c_ptr), ptr). */
1373 block2
->next
= finalization_scalarizer (array
, ptr
,
1374 gfc_lval_expr_from_sym (offset
),
1376 block2
= block2
->next
;
1377 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1378 block2
= block2
->next
;
1381 block2
->next
= XCNEW (gfc_code
);
1382 block2
= block2
->next
;
1383 block2
->op
= EXEC_ASSIGN
;
1384 block2
->loc
= gfc_current_locus
;
1385 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1386 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1388 /* Call now the user's final subroutine. */
1389 block
->next
= XCNEW (gfc_code
);
1390 block
= block
->next
;
1391 block
->op
= EXEC_CALL
;
1392 block
->loc
= gfc_current_locus
;
1393 block
->symtree
= fini
->proc_tree
;
1394 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1395 block
->ext
.actual
= gfc_get_actual_arglist ();
1396 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1398 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1404 iter
= gfc_get_iterator ();
1405 iter
->var
= gfc_lval_expr_from_sym (idx
);
1406 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1407 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1408 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1410 block
->next
= XCNEW (gfc_code
);
1411 block
= block
->next
;
1412 block
->op
= EXEC_DO
;
1413 block
->loc
= gfc_current_locus
;
1414 block
->ext
.iterator
= iter
;
1415 block
->block
= gfc_get_code ();
1416 block
->block
->op
= EXEC_DO
;
1418 /* Offset calculation of "array". */
1419 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1420 byte_stride
, rank
, block
->block
, sub_ns
);
1423 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1424 + offset, c_ptr), ptr). */
1425 block2
->next
= finalization_scalarizer (array
, ptr
,
1426 gfc_lval_expr_from_sym (offset
),
1428 block2
= block2
->next
;
1429 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1430 gfc_copy_expr (offset2
), sub_ns
);
1431 block2
= block2
->next
;
1434 block2
->next
= XCNEW (gfc_code
);
1435 block2
->next
->op
= EXEC_ASSIGN
;
1436 block2
->next
->loc
= gfc_current_locus
;
1437 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1438 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1442 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1443 derived type "derived". The function first calls the approriate FINAL
1444 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1445 components (but not the inherited ones). Last, it calls the wrapper
1446 subroutine of the parent. The generated wrapper procedure takes as argument
1447 an assumed-rank array.
1448 If neither allocatable components nor FINAL subroutines exists, the vtab
1449 will contain a NULL pointer.
1450 The generated function has the form
1451 _final(assumed-rank array, stride, skip_corarray)
1452 where the array has to be contiguous (except of the lowest dimension). The
1453 stride (in bytes) is used to allow different sizes for ancestor types by
1454 skipping over the additionally added components in the scalarizer. If
1455 "fini_coarray" is false, coarray components are not finalized to allow for
1456 the correct semantic with intrinsic assignment. */
1459 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1460 const char *tname
, gfc_component
*vtab_final
)
1462 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1463 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1464 gfc_component
*comp
;
1465 gfc_namespace
*sub_ns
;
1466 gfc_code
*last_code
, *block
;
1467 char name
[GFC_MAX_SYMBOL_LEN
+1];
1468 bool finalizable_comp
= false;
1469 bool expr_null_wrapper
= false;
1470 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1473 /* Search for the ancestor's finalizers. */
1474 if (derived
->attr
.extension
&& derived
->components
1475 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1476 || has_finalizer_component (derived
)))
1479 gfc_component
*comp
;
1481 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1482 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1483 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1485 ancestor_wrapper
= comp
->initializer
;
1490 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1491 components: Return a NULL() expression; we defer this a bit to have have
1492 an interface declaration. */
1493 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1494 && !derived
->attr
.alloc_comp
1495 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1496 && !has_finalizer_component (derived
))
1497 expr_null_wrapper
= true;
1499 /* Check whether there are new allocatable components. */
1500 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1502 if (comp
== derived
->components
&& derived
->attr
.extension
1503 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1506 if (comp
->ts
.type
!= BT_CLASS
&& !comp
->attr
.pointer
1507 && (comp
->attr
.allocatable
1508 || (comp
->ts
.type
== BT_DERIVED
1509 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1510 || has_finalizer_component (comp
->ts
.u
.derived
)
1511 || (comp
->ts
.u
.derived
->f2k_derived
1512 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))))
1513 finalizable_comp
= true;
1514 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1515 && CLASS_DATA (comp
)->attr
.allocatable
)
1516 finalizable_comp
= true;
1519 /* If there is no new finalizer and no new allocatable, return with
1520 an expr to the ancestor's one. */
1521 if (!expr_null_wrapper
&& !finalizable_comp
1522 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1524 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1525 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1526 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1527 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1531 /* We now create a wrapper, which does the following:
1532 1. Call the suitable finalization subroutine for this type
1533 2. Loop over all noninherited allocatable components and noninherited
1534 components with allocatable components and DEALLOCATE those; this will
1535 take care of finalizers, coarray deregistering and allocatable
1537 3. Call the ancestor's finalizer. */
1539 /* Declare the wrapper function; it takes an assumed-rank array
1540 and a VALUE logical as arguments. */
1542 /* Set up the namespace. */
1543 sub_ns
= gfc_get_namespace (ns
, 0);
1544 sub_ns
->sibling
= ns
->contained
;
1545 if (!expr_null_wrapper
)
1546 ns
->contained
= sub_ns
;
1547 sub_ns
->resolved
= 1;
1549 /* Set up the procedure symbol. */
1550 sprintf (name
, "__final_%s", tname
);
1551 gfc_get_symbol (name
, sub_ns
, &final
);
1552 sub_ns
->proc_name
= final
;
1553 final
->attr
.flavor
= FL_PROCEDURE
;
1554 final
->attr
.function
= 1;
1555 final
->attr
.pure
= 0;
1556 final
->result
= final
;
1557 final
->ts
.type
= BT_INTEGER
;
1559 final
->attr
.artificial
= 1;
1560 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1561 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1562 final
->module
= ns
->proc_name
->name
;
1563 gfc_set_sym_referenced (final
);
1564 gfc_commit_symbol (final
);
1566 /* Set up formal argument. */
1567 gfc_get_symbol ("array", sub_ns
, &array
);
1568 array
->ts
.type
= BT_DERIVED
;
1569 array
->ts
.u
.derived
= derived
;
1570 array
->attr
.flavor
= FL_VARIABLE
;
1571 array
->attr
.dummy
= 1;
1572 array
->attr
.contiguous
= 1;
1573 array
->attr
.dimension
= 1;
1574 array
->attr
.artificial
= 1;
1575 array
->as
= gfc_get_array_spec();
1576 array
->as
->type
= AS_ASSUMED_RANK
;
1577 array
->as
->rank
= -1;
1578 array
->attr
.intent
= INTENT_INOUT
;
1579 gfc_set_sym_referenced (array
);
1580 final
->formal
= gfc_get_formal_arglist ();
1581 final
->formal
->sym
= array
;
1582 gfc_commit_symbol (array
);
1584 /* Set up formal argument. */
1585 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1586 byte_stride
->ts
.type
= BT_INTEGER
;
1587 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1588 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1589 byte_stride
->attr
.dummy
= 1;
1590 byte_stride
->attr
.value
= 1;
1591 byte_stride
->attr
.artificial
= 1;
1592 gfc_set_sym_referenced (byte_stride
);
1593 final
->formal
->next
= gfc_get_formal_arglist ();
1594 final
->formal
->next
->sym
= byte_stride
;
1595 gfc_commit_symbol (byte_stride
);
1597 /* Set up formal argument. */
1598 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1599 fini_coarray
->ts
.type
= BT_LOGICAL
;
1600 fini_coarray
->ts
.kind
= 1;
1601 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1602 fini_coarray
->attr
.dummy
= 1;
1603 fini_coarray
->attr
.value
= 1;
1604 fini_coarray
->attr
.artificial
= 1;
1605 gfc_set_sym_referenced (fini_coarray
);
1606 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1607 final
->formal
->next
->next
->sym
= fini_coarray
;
1608 gfc_commit_symbol (fini_coarray
);
1610 /* Return with a NULL() expression but with an interface which has
1611 the formal arguments. */
1612 if (expr_null_wrapper
)
1614 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1615 vtab_final
->ts
.interface
= final
;
1619 /* Local variables. */
1621 gfc_get_symbol ("idx", sub_ns
, &idx
);
1622 idx
->ts
.type
= BT_INTEGER
;
1623 idx
->ts
.kind
= gfc_index_integer_kind
;
1624 idx
->attr
.flavor
= FL_VARIABLE
;
1625 idx
->attr
.artificial
= 1;
1626 gfc_set_sym_referenced (idx
);
1627 gfc_commit_symbol (idx
);
1629 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1630 idx2
->ts
.type
= BT_INTEGER
;
1631 idx2
->ts
.kind
= gfc_index_integer_kind
;
1632 idx2
->attr
.flavor
= FL_VARIABLE
;
1633 idx2
->attr
.artificial
= 1;
1634 gfc_set_sym_referenced (idx2
);
1635 gfc_commit_symbol (idx2
);
1637 gfc_get_symbol ("offset", sub_ns
, &offset
);
1638 offset
->ts
.type
= BT_INTEGER
;
1639 offset
->ts
.kind
= gfc_index_integer_kind
;
1640 offset
->attr
.flavor
= FL_VARIABLE
;
1641 offset
->attr
.artificial
= 1;
1642 gfc_set_sym_referenced (offset
);
1643 gfc_commit_symbol (offset
);
1645 /* Create RANK expression. */
1646 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1647 gfc_current_locus
, 1,
1648 gfc_lval_expr_from_sym (array
));
1649 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1650 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1652 /* Create is_contiguous variable. */
1653 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1654 is_contiguous
->ts
.type
= BT_LOGICAL
;
1655 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1656 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1657 is_contiguous
->attr
.artificial
= 1;
1658 gfc_set_sym_referenced (is_contiguous
);
1659 gfc_commit_symbol (is_contiguous
);
1661 /* Create "sizes(0..rank)" variable, which contains the multiplied
1662 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1663 sizes(2) = sizes(1) * extent(dim=2) etc. */
1664 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1665 sizes
->ts
.type
= BT_INTEGER
;
1666 sizes
->ts
.kind
= gfc_index_integer_kind
;
1667 sizes
->attr
.flavor
= FL_VARIABLE
;
1668 sizes
->attr
.dimension
= 1;
1669 sizes
->attr
.artificial
= 1;
1670 sizes
->as
= gfc_get_array_spec();
1671 sizes
->attr
.intent
= INTENT_INOUT
;
1672 sizes
->as
->type
= AS_EXPLICIT
;
1673 sizes
->as
->rank
= 1;
1674 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1675 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1676 gfc_set_sym_referenced (sizes
);
1677 gfc_commit_symbol (sizes
);
1679 /* Create "strides(1..rank)" variable, which contains the strides per
1681 gfc_get_symbol ("strides", sub_ns
, &strides
);
1682 strides
->ts
.type
= BT_INTEGER
;
1683 strides
->ts
.kind
= gfc_index_integer_kind
;
1684 strides
->attr
.flavor
= FL_VARIABLE
;
1685 strides
->attr
.dimension
= 1;
1686 strides
->attr
.artificial
= 1;
1687 strides
->as
= gfc_get_array_spec();
1688 strides
->attr
.intent
= INTENT_INOUT
;
1689 strides
->as
->type
= AS_EXPLICIT
;
1690 strides
->as
->rank
= 1;
1691 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1692 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1693 gfc_set_sym_referenced (strides
);
1694 gfc_commit_symbol (strides
);
1697 /* Set return value to 0. */
1698 last_code
= XCNEW (gfc_code
);
1699 last_code
->op
= EXEC_ASSIGN
;
1700 last_code
->loc
= gfc_current_locus
;
1701 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1702 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1703 sub_ns
->code
= last_code
;
1705 /* Set: is_contiguous = .true. */
1706 last_code
->next
= XCNEW (gfc_code
);
1707 last_code
= last_code
->next
;
1708 last_code
->op
= EXEC_ASSIGN
;
1709 last_code
->loc
= gfc_current_locus
;
1710 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1711 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1712 &gfc_current_locus
, true);
1714 /* Set: sizes(0) = 1. */
1715 last_code
->next
= XCNEW (gfc_code
);
1716 last_code
= last_code
->next
;
1717 last_code
->op
= EXEC_ASSIGN
;
1718 last_code
->loc
= gfc_current_locus
;
1719 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1720 last_code
->expr1
->ref
= gfc_get_ref ();
1721 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1722 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1723 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1724 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1725 last_code
->expr1
->ref
->u
.ar
.start
[0]
1726 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1727 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1728 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1732 strides(idx) = _F._stride (array, dim=idx)
1733 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1734 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1738 iter
= gfc_get_iterator ();
1739 iter
->var
= gfc_lval_expr_from_sym (idx
);
1740 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1741 iter
->end
= gfc_copy_expr (rank
);
1742 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1743 last_code
->next
= XCNEW (gfc_code
);
1744 last_code
= last_code
->next
;
1745 last_code
->op
= EXEC_DO
;
1746 last_code
->loc
= gfc_current_locus
;
1747 last_code
->ext
.iterator
= iter
;
1748 last_code
->block
= gfc_get_code ();
1749 last_code
->block
->op
= EXEC_DO
;
1751 /* strides(idx) = _F._stride(array,dim=idx). */
1752 last_code
->block
->next
= XCNEW (gfc_code
);
1753 block
= last_code
->block
->next
;
1754 block
->op
= EXEC_ASSIGN
;
1755 block
->loc
= gfc_current_locus
;
1757 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1758 block
->expr1
->ref
= gfc_get_ref ();
1759 block
->expr1
->ref
->type
= REF_ARRAY
;
1760 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1761 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1762 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1763 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1764 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1766 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1767 gfc_current_locus
, 2,
1768 gfc_lval_expr_from_sym (array
),
1769 gfc_lval_expr_from_sym (idx
));
1771 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1772 block
->next
= XCNEW (gfc_code
);
1773 block
= block
->next
;
1774 block
->op
= EXEC_ASSIGN
;
1775 block
->loc
= gfc_current_locus
;
1777 /* sizes(idx) = ... */
1778 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1779 block
->expr1
->ref
= gfc_get_ref ();
1780 block
->expr1
->ref
->type
= REF_ARRAY
;
1781 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1782 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1783 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1784 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1785 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1787 block
->expr2
= gfc_get_expr ();
1788 block
->expr2
->expr_type
= EXPR_OP
;
1789 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1792 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1793 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1794 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1795 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1796 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1797 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1798 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1799 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1800 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1801 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1802 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1803 = gfc_lval_expr_from_sym (idx
);
1804 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1805 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1806 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1807 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1809 /* size(array, dim=idx, kind=index_kind). */
1810 block
->expr2
->value
.op
.op2
1811 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1812 gfc_current_locus
, 3,
1813 gfc_lval_expr_from_sym (array
),
1814 gfc_lval_expr_from_sym (idx
),
1815 gfc_get_int_expr (gfc_index_integer_kind
,
1817 gfc_index_integer_kind
));
1818 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1819 block
->expr2
->ts
= idx
->ts
;
1821 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1822 block
->next
= XCNEW (gfc_code
);
1823 block
= block
->next
;
1824 block
->loc
= gfc_current_locus
;
1825 block
->op
= EXEC_IF
;
1827 block
->block
= XCNEW (gfc_code
);
1828 block
= block
->block
;
1829 block
->loc
= gfc_current_locus
;
1830 block
->op
= EXEC_IF
;
1832 /* if condition: strides(idx) /= sizes(idx-1). */
1833 block
->expr1
= gfc_get_expr ();
1834 block
->expr1
->ts
.type
= BT_LOGICAL
;
1835 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1836 block
->expr1
->expr_type
= EXPR_OP
;
1837 block
->expr1
->where
= gfc_current_locus
;
1838 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1840 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1841 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1842 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1843 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1844 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1845 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1846 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1847 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1849 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1850 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1851 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1852 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1853 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1854 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1855 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1856 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1857 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1858 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1859 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1860 = gfc_lval_expr_from_sym (idx
);
1861 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1862 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1863 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1864 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1866 /* if body: is_contiguous = .false. */
1867 block
->next
= XCNEW (gfc_code
);
1868 block
= block
->next
;
1869 block
->op
= EXEC_ASSIGN
;
1870 block
->loc
= gfc_current_locus
;
1871 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1872 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1873 &gfc_current_locus
, false);
1875 /* Obtain the size (number of elements) of "array" MINUS ONE,
1876 which is used in the scalarization. */
1877 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1878 nelem
->ts
.type
= BT_INTEGER
;
1879 nelem
->ts
.kind
= gfc_index_integer_kind
;
1880 nelem
->attr
.flavor
= FL_VARIABLE
;
1881 nelem
->attr
.artificial
= 1;
1882 gfc_set_sym_referenced (nelem
);
1883 gfc_commit_symbol (nelem
);
1885 /* nelem = sizes (rank) - 1. */
1886 last_code
->next
= XCNEW (gfc_code
);
1887 last_code
= last_code
->next
;
1888 last_code
->op
= EXEC_ASSIGN
;
1889 last_code
->loc
= gfc_current_locus
;
1891 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1893 last_code
->expr2
= gfc_get_expr ();
1894 last_code
->expr2
->expr_type
= EXPR_OP
;
1895 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1896 last_code
->expr2
->value
.op
.op2
1897 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1898 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1900 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1901 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1902 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1903 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1904 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1905 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1906 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1907 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1909 /* Call final subroutines. We now generate code like:
1911 integer, pointer :: ptr
1913 integer(c_intptr_t) :: i, addr
1915 select case (rank (array))
1917 ! If needed, the array is packed
1918 call final_rank3 (array)
1920 do i = 0, size (array)-1
1921 addr = transfer (c_loc (array), addr) + i * stride
1922 call c_f_pointer (transfer (addr, cptr), ptr)
1923 call elemental_final (ptr)
1927 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1929 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1931 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1932 ptr
->ts
.type
= BT_DERIVED
;
1933 ptr
->ts
.u
.derived
= derived
;
1934 ptr
->attr
.flavor
= FL_VARIABLE
;
1935 ptr
->attr
.pointer
= 1;
1936 ptr
->attr
.artificial
= 1;
1937 gfc_set_sym_referenced (ptr
);
1938 gfc_commit_symbol (ptr
);
1940 /* SELECT CASE (RANK (array)). */
1941 last_code
->next
= XCNEW (gfc_code
);
1942 last_code
= last_code
->next
;
1943 last_code
->op
= EXEC_SELECT
;
1944 last_code
->loc
= gfc_current_locus
;
1945 last_code
->expr1
= gfc_copy_expr (rank
);
1948 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1950 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1956 /* CASE (fini_rank). */
1959 block
->block
= XCNEW (gfc_code
);
1960 block
= block
->block
;
1964 block
= XCNEW (gfc_code
);
1965 last_code
->block
= block
;
1967 block
->loc
= gfc_current_locus
;
1968 block
->op
= EXEC_SELECT
;
1969 block
->ext
.block
.case_list
= gfc_get_case ();
1970 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1971 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1972 block
->ext
.block
.case_list
->low
1973 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1974 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1976 block
->ext
.block
.case_list
->low
1977 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1978 block
->ext
.block
.case_list
->high
1979 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
1981 /* CALL fini_rank (array) - possibly with packing. */
1982 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1983 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1984 idx
, ptr
, nelem
, strides
,
1985 sizes
, idx2
, offset
, is_contiguous
,
1989 block
->next
= XCNEW (gfc_code
);
1990 block
->next
->op
= EXEC_CALL
;
1991 block
->next
->loc
= gfc_current_locus
;
1992 block
->next
->symtree
= fini
->proc_tree
;
1993 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1994 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1995 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1999 /* Elemental call - scalarized. */
2005 block
->block
= XCNEW (gfc_code
);
2006 block
= block
->block
;
2010 block
= XCNEW (gfc_code
);
2011 last_code
->block
= block
;
2013 block
->loc
= gfc_current_locus
;
2014 block
->op
= EXEC_SELECT
;
2015 block
->ext
.block
.case_list
= gfc_get_case ();
2018 iter
= gfc_get_iterator ();
2019 iter
->var
= gfc_lval_expr_from_sym (idx
);
2020 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2021 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2022 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2023 block
->next
= XCNEW (gfc_code
);
2024 block
= block
->next
;
2025 block
->op
= EXEC_DO
;
2026 block
->loc
= gfc_current_locus
;
2027 block
->ext
.iterator
= iter
;
2028 block
->block
= gfc_get_code ();
2029 block
->block
->op
= EXEC_DO
;
2031 /* Offset calculation. */
2032 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2033 byte_stride
, rank
, block
->block
,
2037 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2038 + offset, c_ptr), ptr). */
2040 = finalization_scalarizer (array
, ptr
,
2041 gfc_lval_expr_from_sym (offset
),
2043 block
= block
->next
;
2045 /* CALL final_elemental (array). */
2046 block
->next
= XCNEW (gfc_code
);
2047 block
= block
->next
;
2048 block
->op
= EXEC_CALL
;
2049 block
->loc
= gfc_current_locus
;
2050 block
->symtree
= fini_elem
->proc_tree
;
2051 block
->resolved_sym
= fini_elem
->proc_sym
;
2052 block
->ext
.actual
= gfc_get_actual_arglist ();
2053 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2057 /* Finalize and deallocate allocatable components. The same manual
2058 scalarization is used as above. */
2060 if (finalizable_comp
)
2063 gfc_code
*block
= NULL
;
2067 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2068 ptr
->ts
.type
= BT_DERIVED
;
2069 ptr
->ts
.u
.derived
= derived
;
2070 ptr
->attr
.flavor
= FL_VARIABLE
;
2071 ptr
->attr
.pointer
= 1;
2072 ptr
->attr
.artificial
= 1;
2073 gfc_set_sym_referenced (ptr
);
2074 gfc_commit_symbol (ptr
);
2077 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2078 stat
->attr
.flavor
= FL_VARIABLE
;
2079 stat
->attr
.artificial
= 1;
2080 stat
->ts
.type
= BT_INTEGER
;
2081 stat
->ts
.kind
= gfc_default_integer_kind
;
2082 gfc_set_sym_referenced (stat
);
2083 gfc_commit_symbol (stat
);
2086 iter
= gfc_get_iterator ();
2087 iter
->var
= gfc_lval_expr_from_sym (idx
);
2088 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2089 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2090 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2091 last_code
->next
= XCNEW (gfc_code
);
2092 last_code
= last_code
->next
;
2093 last_code
->op
= EXEC_DO
;
2094 last_code
->loc
= gfc_current_locus
;
2095 last_code
->ext
.iterator
= iter
;
2096 last_code
->block
= gfc_get_code ();
2097 last_code
->block
->op
= EXEC_DO
;
2099 /* Offset calculation. */
2100 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2101 byte_stride
, rank
, last_code
->block
,
2105 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2106 + idx * stride, c_ptr), ptr). */
2107 block
->next
= finalization_scalarizer (array
, ptr
,
2108 gfc_lval_expr_from_sym(offset
),
2110 block
= block
->next
;
2112 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2114 if (comp
== derived
->components
&& derived
->attr
.extension
2115 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2118 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2119 stat
, fini_coarray
, &block
);
2120 if (!last_code
->block
->next
)
2121 last_code
->block
->next
= block
;
2126 /* Call the finalizer of the ancestor. */
2127 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2129 last_code
->next
= XCNEW (gfc_code
);
2130 last_code
= last_code
->next
;
2131 last_code
->op
= EXEC_CALL
;
2132 last_code
->loc
= gfc_current_locus
;
2133 last_code
->symtree
= ancestor_wrapper
->symtree
;
2134 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2136 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2137 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2138 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2139 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2140 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2141 last_code
->ext
.actual
->next
->next
->expr
2142 = gfc_lval_expr_from_sym (fini_coarray
);
2145 gfc_free_expr (rank
);
2146 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2147 vtab_final
->ts
.interface
= final
;
2151 /* Add procedure pointers for all type-bound procedures to a vtab. */
2154 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2156 gfc_symbol
* super_type
;
2158 super_type
= gfc_get_derived_super_type (derived
);
2160 if (super_type
&& (super_type
!= derived
))
2162 /* Make sure that the PPCs appear in the same order as in the parent. */
2163 copy_vtab_proc_comps (super_type
, vtype
);
2164 /* Only needed to get the PPC initializers right. */
2165 add_procs_to_declared_vtab (super_type
, vtype
);
2168 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2169 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2171 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2172 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2176 /* Find or generate the symbol for a derived type's vtab. */
2179 gfc_find_derived_vtab (gfc_symbol
*derived
)
2182 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2183 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2185 /* Find the top-level namespace. */
2186 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2190 /* If the type is a class container, use the underlying derived type. */
2191 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2192 derived
= gfc_get_derived_super_type (derived
);
2196 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2198 get_unique_hashed_string (tname
, derived
);
2199 sprintf (name
, "__vtab_%s", tname
);
2201 /* Look for the vtab symbol in various namespaces. */
2202 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2204 gfc_find_symbol (name
, ns
, 0, &vtab
);
2206 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2210 gfc_get_symbol (name
, ns
, &vtab
);
2211 vtab
->ts
.type
= BT_DERIVED
;
2212 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2213 &gfc_current_locus
))
2215 vtab
->attr
.target
= 1;
2216 vtab
->attr
.save
= SAVE_IMPLICIT
;
2217 vtab
->attr
.vtab
= 1;
2218 vtab
->attr
.access
= ACCESS_PUBLIC
;
2219 gfc_set_sym_referenced (vtab
);
2220 sprintf (name
, "__vtype_%s", tname
);
2222 gfc_find_symbol (name
, ns
, 0, &vtype
);
2226 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2228 gfc_get_symbol (name
, ns
, &vtype
);
2229 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2230 &gfc_current_locus
))
2232 vtype
->attr
.access
= ACCESS_PUBLIC
;
2233 vtype
->attr
.vtype
= 1;
2234 gfc_set_sym_referenced (vtype
);
2236 /* Add component '_hash'. */
2237 if (!gfc_add_component (vtype
, "_hash", &c
))
2239 c
->ts
.type
= BT_INTEGER
;
2241 c
->attr
.access
= ACCESS_PRIVATE
;
2242 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2243 NULL
, derived
->hash_value
);
2245 /* Add component '_size'. */
2246 if (!gfc_add_component (vtype
, "_size", &c
))
2248 c
->ts
.type
= BT_INTEGER
;
2250 c
->attr
.access
= ACCESS_PRIVATE
;
2251 /* Remember the derived type in ts.u.derived,
2252 so that the correct initializer can be set later on
2253 (in gfc_conv_structure). */
2254 c
->ts
.u
.derived
= derived
;
2255 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2258 /* Add component _extends. */
2259 if (!gfc_add_component (vtype
, "_extends", &c
))
2261 c
->attr
.pointer
= 1;
2262 c
->attr
.access
= ACCESS_PRIVATE
;
2263 if (!derived
->attr
.unlimited_polymorphic
)
2264 parent
= gfc_get_derived_super_type (derived
);
2270 parent_vtab
= gfc_find_derived_vtab (parent
);
2271 c
->ts
.type
= BT_DERIVED
;
2272 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2273 c
->initializer
= gfc_get_expr ();
2274 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2275 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2276 0, &c
->initializer
->symtree
);
2280 c
->ts
.type
= BT_DERIVED
;
2281 c
->ts
.u
.derived
= vtype
;
2282 c
->initializer
= gfc_get_null_expr (NULL
);
2285 if (!derived
->attr
.unlimited_polymorphic
2286 && derived
->components
== NULL
2287 && !derived
->attr
.zero_comp
)
2289 /* At this point an error must have occurred.
2290 Prevent further errors on the vtype components. */
2295 /* Add component _def_init. */
2296 if (!gfc_add_component (vtype
, "_def_init", &c
))
2298 c
->attr
.pointer
= 1;
2299 c
->attr
.artificial
= 1;
2300 c
->attr
.access
= ACCESS_PRIVATE
;
2301 c
->ts
.type
= BT_DERIVED
;
2302 c
->ts
.u
.derived
= derived
;
2303 if (derived
->attr
.unlimited_polymorphic
2304 || derived
->attr
.abstract
)
2305 c
->initializer
= gfc_get_null_expr (NULL
);
2308 /* Construct default initialization variable. */
2309 sprintf (name
, "__def_init_%s", tname
);
2310 gfc_get_symbol (name
, ns
, &def_init
);
2311 def_init
->attr
.target
= 1;
2312 def_init
->attr
.artificial
= 1;
2313 def_init
->attr
.save
= SAVE_IMPLICIT
;
2314 def_init
->attr
.access
= ACCESS_PUBLIC
;
2315 def_init
->attr
.flavor
= FL_VARIABLE
;
2316 gfc_set_sym_referenced (def_init
);
2317 def_init
->ts
.type
= BT_DERIVED
;
2318 def_init
->ts
.u
.derived
= derived
;
2319 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2321 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2324 /* Add component _copy. */
2325 if (!gfc_add_component (vtype
, "_copy", &c
))
2327 c
->attr
.proc_pointer
= 1;
2328 c
->attr
.access
= ACCESS_PRIVATE
;
2329 c
->tb
= XCNEW (gfc_typebound_proc
);
2331 if (derived
->attr
.unlimited_polymorphic
2332 || derived
->attr
.abstract
)
2333 c
->initializer
= gfc_get_null_expr (NULL
);
2336 /* Set up namespace. */
2337 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2338 sub_ns
->sibling
= ns
->contained
;
2339 ns
->contained
= sub_ns
;
2340 sub_ns
->resolved
= 1;
2341 /* Set up procedure symbol. */
2342 sprintf (name
, "__copy_%s", tname
);
2343 gfc_get_symbol (name
, sub_ns
, ©
);
2344 sub_ns
->proc_name
= copy
;
2345 copy
->attr
.flavor
= FL_PROCEDURE
;
2346 copy
->attr
.subroutine
= 1;
2347 copy
->attr
.pure
= 1;
2348 copy
->attr
.artificial
= 1;
2349 copy
->attr
.if_source
= IFSRC_DECL
;
2350 /* This is elemental so that arrays are automatically
2351 treated correctly by the scalarizer. */
2352 copy
->attr
.elemental
= 1;
2353 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2354 copy
->module
= ns
->proc_name
->name
;
2355 gfc_set_sym_referenced (copy
);
2356 /* Set up formal arguments. */
2357 gfc_get_symbol ("src", sub_ns
, &src
);
2358 src
->ts
.type
= BT_DERIVED
;
2359 src
->ts
.u
.derived
= derived
;
2360 src
->attr
.flavor
= FL_VARIABLE
;
2361 src
->attr
.dummy
= 1;
2362 src
->attr
.artificial
= 1;
2363 src
->attr
.intent
= INTENT_IN
;
2364 gfc_set_sym_referenced (src
);
2365 copy
->formal
= gfc_get_formal_arglist ();
2366 copy
->formal
->sym
= src
;
2367 gfc_get_symbol ("dst", sub_ns
, &dst
);
2368 dst
->ts
.type
= BT_DERIVED
;
2369 dst
->ts
.u
.derived
= derived
;
2370 dst
->attr
.flavor
= FL_VARIABLE
;
2371 dst
->attr
.dummy
= 1;
2372 dst
->attr
.artificial
= 1;
2373 dst
->attr
.intent
= INTENT_INOUT
;
2374 gfc_set_sym_referenced (dst
);
2375 copy
->formal
->next
= gfc_get_formal_arglist ();
2376 copy
->formal
->next
->sym
= dst
;
2378 sub_ns
->code
= gfc_get_code ();
2379 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2380 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2381 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2382 /* Set initializer. */
2383 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2384 c
->ts
.interface
= copy
;
2387 /* Add component _final, which contains a procedure pointer to
2388 a wrapper which handles both the freeing of allocatable
2389 components and the calls to finalization subroutines.
2390 Note: The actual wrapper function can only be generated
2391 at resolution time. */
2392 if (!gfc_add_component (vtype
, "_final", &c
))
2394 c
->attr
.proc_pointer
= 1;
2395 c
->attr
.access
= ACCESS_PRIVATE
;
2396 c
->tb
= XCNEW (gfc_typebound_proc
);
2398 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2400 /* Add procedure pointers for type-bound procedures. */
2401 if (!derived
->attr
.unlimited_polymorphic
)
2402 add_procs_to_declared_vtab (derived
, vtype
);
2406 vtab
->ts
.u
.derived
= vtype
;
2407 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2414 /* It is unexpected to have some symbols added at resolution or code
2415 generation time. We commit the changes in order to keep a clean state. */
2418 gfc_commit_symbol (vtab
);
2420 gfc_commit_symbol (vtype
);
2422 gfc_commit_symbol (def_init
);
2424 gfc_commit_symbol (copy
);
2426 gfc_commit_symbol (src
);
2428 gfc_commit_symbol (dst
);
2431 gfc_undo_symbols ();
2437 /* Check if a derived type is finalizable. That is the case if it
2438 (1) has a FINAL subroutine or
2439 (2) has a nonpointer nonallocatable component of finalizable type.
2440 If it is finalizable, return an expression containing the
2441 finalization wrapper. */
2444 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2449 /* (1) Check for FINAL subroutines. */
2450 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2453 /* (2) Check for components of finalizable type. */
2454 for (c
= derived
->components
; c
; c
= c
->next
)
2455 if (c
->ts
.type
== BT_DERIVED
2456 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2457 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2463 /* Make sure vtab is generated. */
2464 vtab
= gfc_find_derived_vtab (derived
);
2467 /* Return finalizer expression. */
2468 gfc_component
*final
;
2469 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2470 gcc_assert (strcmp (final
->name
, "_final") == 0);
2471 gcc_assert (final
->initializer
2472 && final
->initializer
->expr_type
!= EXPR_NULL
);
2473 *final_expr
= final
->initializer
;
2479 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2480 need to support unlimited polymorphism. */
2483 gfc_find_intrinsic_vtab (gfc_typespec
*ts
)
2486 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2487 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2490 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2492 gfc_error ("TODO: Deferred character length variable at %C cannot "
2493 "yet be associated with unlimited polymorphic entities");
2497 if (ts
->type
== BT_UNKNOWN
)
2500 /* Sometimes the typespec is passed from a single call. */
2501 if (ts
->type
== BT_DERIVED
)
2502 return gfc_find_derived_vtab (ts
->u
.derived
);
2504 /* Find the top-level namespace. */
2505 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2509 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
2510 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2511 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2515 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2517 if (ts
->type
== BT_CHARACTER
)
2518 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2521 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2523 sprintf (name
, "__vtab_%s", tname
);
2525 /* Look for the vtab symbol in various namespaces. */
2526 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2528 gfc_find_symbol (name
, ns
, 0, &vtab
);
2532 gfc_get_symbol (name
, ns
, &vtab
);
2533 vtab
->ts
.type
= BT_DERIVED
;
2534 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2535 &gfc_current_locus
))
2537 vtab
->attr
.target
= 1;
2538 vtab
->attr
.save
= SAVE_IMPLICIT
;
2539 vtab
->attr
.vtab
= 1;
2540 vtab
->attr
.access
= ACCESS_PUBLIC
;
2541 gfc_set_sym_referenced (vtab
);
2542 sprintf (name
, "__vtype_%s", tname
);
2544 gfc_find_symbol (name
, ns
, 0, &vtype
);
2549 gfc_namespace
*sub_ns
;
2550 gfc_namespace
*contained
;
2552 gfc_get_symbol (name
, ns
, &vtype
);
2553 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2554 &gfc_current_locus
))
2556 vtype
->attr
.access
= ACCESS_PUBLIC
;
2557 vtype
->attr
.vtype
= 1;
2558 gfc_set_sym_referenced (vtype
);
2560 /* Add component '_hash'. */
2561 if (!gfc_add_component (vtype
, "_hash", &c
))
2563 c
->ts
.type
= BT_INTEGER
;
2565 c
->attr
.access
= ACCESS_PRIVATE
;
2566 hash
= gfc_intrinsic_hash_value (ts
);
2567 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2570 /* Add component '_size'. */
2571 if (!gfc_add_component (vtype
, "_size", &c
))
2573 c
->ts
.type
= BT_INTEGER
;
2575 c
->attr
.access
= ACCESS_PRIVATE
;
2576 if (ts
->type
== BT_CHARACTER
)
2577 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2578 NULL
, charlen
*ts
->kind
);
2580 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2583 /* Add component _extends. */
2584 if (!gfc_add_component (vtype
, "_extends", &c
))
2586 c
->attr
.pointer
= 1;
2587 c
->attr
.access
= ACCESS_PRIVATE
;
2588 c
->ts
.type
= BT_VOID
;
2589 c
->initializer
= gfc_get_null_expr (NULL
);
2591 /* Add component _def_init. */
2592 if (!gfc_add_component (vtype
, "_def_init", &c
))
2594 c
->attr
.pointer
= 1;
2595 c
->attr
.access
= ACCESS_PRIVATE
;
2596 c
->ts
.type
= BT_VOID
;
2597 c
->initializer
= gfc_get_null_expr (NULL
);
2599 /* Add component _copy. */
2600 if (!gfc_add_component (vtype
, "_copy", &c
))
2602 c
->attr
.proc_pointer
= 1;
2603 c
->attr
.access
= ACCESS_PRIVATE
;
2604 c
->tb
= XCNEW (gfc_typebound_proc
);
2607 /* Check to see if copy function already exists. Note
2608 that this is only used for characters of different
2610 contained
= ns
->contained
;
2611 for (; contained
; contained
= contained
->sibling
)
2612 if (contained
->proc_name
2613 && strcmp (name
, contained
->proc_name
->name
) == 0)
2615 copy
= contained
->proc_name
;
2619 /* Set up namespace. */
2620 sub_ns
= gfc_get_namespace (ns
, 0);
2621 sub_ns
->sibling
= ns
->contained
;
2622 ns
->contained
= sub_ns
;
2623 sub_ns
->resolved
= 1;
2624 /* Set up procedure symbol. */
2625 if (ts
->type
!= BT_CHARACTER
)
2626 sprintf (name
, "__copy_%s", tname
);
2628 /* __copy is always the same for characters. */
2629 sprintf (name
, "__copy_character_%d", ts
->kind
);
2630 gfc_get_symbol (name
, sub_ns
, ©
);
2631 sub_ns
->proc_name
= copy
;
2632 copy
->attr
.flavor
= FL_PROCEDURE
;
2633 copy
->attr
.subroutine
= 1;
2634 copy
->attr
.pure
= 1;
2635 copy
->attr
.if_source
= IFSRC_DECL
;
2636 /* This is elemental so that arrays are automatically
2637 treated correctly by the scalarizer. */
2638 copy
->attr
.elemental
= 1;
2639 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2640 copy
->module
= ns
->proc_name
->name
;
2641 gfc_set_sym_referenced (copy
);
2642 /* Set up formal arguments. */
2643 gfc_get_symbol ("src", sub_ns
, &src
);
2644 src
->ts
.type
= ts
->type
;
2645 src
->ts
.kind
= ts
->kind
;
2646 src
->attr
.flavor
= FL_VARIABLE
;
2647 src
->attr
.dummy
= 1;
2648 src
->attr
.intent
= INTENT_IN
;
2649 gfc_set_sym_referenced (src
);
2650 copy
->formal
= gfc_get_formal_arglist ();
2651 copy
->formal
->sym
= src
;
2652 gfc_get_symbol ("dst", sub_ns
, &dst
);
2653 dst
->ts
.type
= ts
->type
;
2654 dst
->ts
.kind
= ts
->kind
;
2655 dst
->attr
.flavor
= FL_VARIABLE
;
2656 dst
->attr
.dummy
= 1;
2657 dst
->attr
.intent
= INTENT_INOUT
;
2658 gfc_set_sym_referenced (dst
);
2659 copy
->formal
->next
= gfc_get_formal_arglist ();
2660 copy
->formal
->next
->sym
= dst
;
2662 sub_ns
->code
= gfc_get_code ();
2663 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2664 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2665 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2667 /* Set initializer. */
2668 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2669 c
->ts
.interface
= copy
;
2671 /* Add component _final. */
2672 if (!gfc_add_component (vtype
, "_final", &c
))
2674 c
->attr
.proc_pointer
= 1;
2675 c
->attr
.access
= ACCESS_PRIVATE
;
2676 c
->tb
= XCNEW (gfc_typebound_proc
);
2678 c
->initializer
= gfc_get_null_expr (NULL
);
2680 vtab
->ts
.u
.derived
= vtype
;
2681 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2688 /* It is unexpected to have some symbols added at resolution or code
2689 generation time. We commit the changes in order to keep a clean state. */
2692 gfc_commit_symbol (vtab
);
2694 gfc_commit_symbol (vtype
);
2696 gfc_commit_symbol (copy
);
2698 gfc_commit_symbol (src
);
2700 gfc_commit_symbol (dst
);
2703 gfc_undo_symbols ();
2709 /* General worker function to find either a type-bound procedure or a
2710 type-bound user operator. */
2713 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2714 const char* name
, bool noaccess
, bool uop
,
2720 /* Set default to failure. */
2724 if (derived
->f2k_derived
)
2725 /* Set correct symbol-root. */
2726 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2727 : derived
->f2k_derived
->tb_sym_root
);
2731 /* Try to find it in the current type's namespace. */
2732 res
= gfc_find_symtree (root
, name
);
2733 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2739 if (!noaccess
&& derived
->attr
.use_assoc
2740 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2743 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2744 name
, derived
->name
, where
);
2752 /* Otherwise, recurse on parent type if derived is an extension. */
2753 if (derived
->attr
.extension
)
2755 gfc_symbol
* super_type
;
2756 super_type
= gfc_get_derived_super_type (derived
);
2757 gcc_assert (super_type
);
2759 return find_typebound_proc_uop (super_type
, t
, name
,
2760 noaccess
, uop
, where
);
2763 /* Nothing found. */
2768 /* Find a type-bound procedure or user operator by name for a derived-type
2769 (looking recursively through the super-types). */
2772 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2773 const char* name
, bool noaccess
, locus
* where
)
2775 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2779 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2780 const char* name
, bool noaccess
, locus
* where
)
2782 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2786 /* Find a type-bound intrinsic operator looking recursively through the
2787 super-type hierarchy. */
2790 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2791 gfc_intrinsic_op op
, bool noaccess
,
2794 gfc_typebound_proc
* res
;
2796 /* Set default to failure. */
2800 /* Try to find it in the current type's namespace. */
2801 if (derived
->f2k_derived
)
2802 res
= derived
->f2k_derived
->tb_op
[op
];
2807 if (res
&& !res
->error
)
2813 if (!noaccess
&& derived
->attr
.use_assoc
2814 && res
->access
== ACCESS_PRIVATE
)
2817 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2818 gfc_op2string (op
), derived
->name
, where
);
2826 /* Otherwise, recurse on parent type if derived is an extension. */
2827 if (derived
->attr
.extension
)
2829 gfc_symbol
* super_type
;
2830 super_type
= gfc_get_derived_super_type (derived
);
2831 gcc_assert (super_type
);
2833 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2837 /* Nothing found. */
2842 /* Get a typebound-procedure symtree or create and insert it if not yet
2843 present. This is like a very simplified version of gfc_get_sym_tree for
2844 tbp-symtrees rather than regular ones. */
2847 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2849 gfc_symtree
*result
;
2851 result
= gfc_find_symtree (*root
, name
);
2854 result
= gfc_new_symtree (root
, name
);
2855 gcc_assert (result
);
2856 result
->n
.tb
= NULL
;