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 a NULL initializer for CLASS pointers,
416 initializing the _data component to NULL and
417 the _vptr component to the declared type. */
420 gfc_class_null_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
);
434 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
436 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
437 &ts
->u
.derived
->declared_at
);
440 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
442 gfc_constructor
*ctor
= gfc_constructor_get();
443 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
444 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
446 ctor
->expr
= gfc_get_null_expr (NULL
);
447 gfc_constructor_append (&init
->value
.constructor
, ctor
);
454 /* Create a unique string identifier for a derived type, composed of its name
455 and module name. This is used to construct unique names for the class
456 containers and vtab symbols. */
459 get_unique_type_string (char *string
, gfc_symbol
*derived
)
461 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
462 if (derived
->attr
.unlimited_polymorphic
)
463 sprintf (dt_name
, "%s", "$tar");
465 sprintf (dt_name
, "%s", derived
->name
);
466 dt_name
[0] = TOUPPER (dt_name
[0]);
467 if (derived
->attr
.unlimited_polymorphic
)
468 sprintf (string
, "_%s", dt_name
);
469 else if (derived
->module
)
470 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
471 else if (derived
->ns
->proc_name
)
472 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
474 sprintf (string
, "_%s", dt_name
);
478 /* A relative of 'get_unique_type_string' which makes sure the generated
479 string will not be too long (replacing it by a hash string if needed). */
482 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
484 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
485 get_unique_type_string (&tmp
[0], derived
);
486 /* If string is too long, use hash value in hex representation (allow for
487 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
488 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
489 where %d is the (co)rank which can be up to n = 15. */
490 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
492 int h
= gfc_hash_value (derived
);
493 sprintf (string
, "%X", h
);
496 strcpy (string
, tmp
);
500 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
503 gfc_hash_value (gfc_symbol
*sym
)
505 unsigned int hash
= 0;
506 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
509 get_unique_type_string (&c
[0], sym
);
512 for (i
= 0; i
< len
; i
++)
513 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
515 /* Return the hash but take the modulus for the sake of module read,
516 even though this slightly increases the chance of collision. */
517 return (hash
% 100000000);
521 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
524 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
526 unsigned int hash
= 0;
527 const char *c
= gfc_typename (ts
);
532 for (i
= 0; i
< len
; i
++)
533 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
535 /* Return the hash but take the modulus for the sake of module read,
536 even though this slightly increases the chance of collision. */
537 return (hash
% 100000000);
541 /* Build a polymorphic CLASS entity, using the symbol that comes from
542 build_sym. A CLASS entity is represented by an encapsulating type,
543 which contains the declared type as '_data' component, plus a pointer
544 component '_vptr' which determines the dynamic type. */
547 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
548 gfc_array_spec
**as
, bool delayed_vtab
)
550 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
559 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
561 gfc_error ("Assumed size polymorphic objects or components, such "
562 "as that at %C, have not yet been implemented");
567 /* Class container has already been built. */
570 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
571 || attr
->select_type_temporary
;
574 /* We can not build the class container yet. */
577 /* Determine the name of the encapsulating type. */
578 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
579 get_unique_hashed_string (tname
, ts
->u
.derived
);
580 if ((*as
) && attr
->allocatable
)
581 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
582 else if ((*as
) && attr
->pointer
)
583 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
585 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
586 else if (attr
->pointer
)
587 sprintf (name
, "__class_%s_p", tname
);
588 else if (attr
->allocatable
)
589 sprintf (name
, "__class_%s_a", tname
);
591 sprintf (name
, "__class_%s", tname
);
593 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
595 /* Find the top-level namespace. */
596 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
601 ns
= ts
->u
.derived
->ns
;
603 gfc_find_symbol (name
, ns
, 0, &fclass
);
607 /* If not there, create a new symbol. */
608 fclass
= gfc_new_symbol (name
, ns
);
609 st
= gfc_new_symtree (&ns
->sym_root
, name
);
611 gfc_set_sym_referenced (fclass
);
613 fclass
->ts
.type
= BT_UNKNOWN
;
614 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
615 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
616 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
617 if (gfc_add_flavor (&fclass
->attr
, FL_DERIVED
,
618 NULL
, &gfc_current_locus
) == FAILURE
)
621 /* Add component '_data'. */
622 if (gfc_add_component (fclass
, "_data", &c
) == FAILURE
)
625 c
->ts
.type
= BT_DERIVED
;
626 c
->attr
.access
= ACCESS_PRIVATE
;
627 c
->ts
.u
.derived
= ts
->u
.derived
;
628 c
->attr
.class_pointer
= attr
->pointer
;
629 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
630 || attr
->select_type_temporary
;
631 c
->attr
.allocatable
= attr
->allocatable
;
632 c
->attr
.dimension
= attr
->dimension
;
633 c
->attr
.codimension
= attr
->codimension
;
634 c
->attr
.abstract
= fclass
->attr
.abstract
;
636 c
->initializer
= NULL
;
638 /* Add component '_vptr'. */
639 if (gfc_add_component (fclass
, "_vptr", &c
) == FAILURE
)
641 c
->ts
.type
= BT_DERIVED
;
643 || (ts
->u
.derived
->f2k_derived
644 && ts
->u
.derived
->f2k_derived
->finalizers
))
645 c
->ts
.u
.derived
= NULL
;
648 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
650 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
652 c
->attr
.access
= ACCESS_PRIVATE
;
656 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
658 /* Since the extension field is 8 bit wide, we can only have
659 up to 255 extension levels. */
660 if (ts
->u
.derived
->attr
.extension
== 255)
662 gfc_error ("Maximum extension level reached with type '%s' at %L",
663 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
667 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
668 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
671 fclass
->attr
.is_class
= 1;
672 ts
->u
.derived
= fclass
;
673 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
679 /* Add a procedure pointer component to the vtype
680 to represent a specific type-bound procedure. */
683 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
687 if (tb
->non_overridable
)
690 c
= gfc_find_component (vtype
, name
, true, true);
694 /* Add procedure component. */
695 if (gfc_add_component (vtype
, name
, &c
) == FAILURE
)
699 c
->tb
= XCNEW (gfc_typebound_proc
);
702 c
->attr
.procedure
= 1;
703 c
->attr
.proc_pointer
= 1;
704 c
->attr
.flavor
= FL_PROCEDURE
;
705 c
->attr
.access
= ACCESS_PRIVATE
;
706 c
->attr
.external
= 1;
708 c
->attr
.if_source
= IFSRC_IFBODY
;
710 else if (c
->attr
.proc_pointer
&& c
->tb
)
718 c
->ts
.interface
= tb
->u
.specific
->n
.sym
;
720 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
725 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
728 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
734 add_procs_to_declared_vtab1 (st
->left
, vtype
);
737 add_procs_to_declared_vtab1 (st
->right
, vtype
);
739 if (st
->n
.tb
&& !st
->n
.tb
->error
740 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
741 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
745 /* Copy procedure pointers components from the parent type. */
748 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
753 vtab
= gfc_find_derived_vtab (declared
);
755 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
757 if (gfc_find_component (vtype
, cmp
->name
, true, true))
760 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
765 /* Returns true if any of its nonpointer nonallocatable components or
766 their nonpointer nonallocatable subcomponents has a finalization
770 has_finalizer_component (gfc_symbol
*derived
)
774 for (c
= derived
->components
; c
; c
= c
->next
)
776 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
777 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
780 if (c
->ts
.type
== BT_DERIVED
781 && !c
->attr
.pointer
&& !c
->attr
.allocatable
782 && has_finalizer_component (c
->ts
.u
.derived
))
789 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
790 neither allocatable nor a pointer but has a finalizer, call it. If it
791 is a nonpointer component with allocatable components or has finalizers, walk
792 them. Either of them is required; other nonallocatables and pointers aren't
794 Note: If the component is allocatable, the DEALLOCATE handling takes care
795 of calling the appropriate finalizers, coarray deregistering, and
796 deallocation of allocatable subcomponents. */
799 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
800 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
)
805 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
806 && !comp
->attr
.allocatable
)
809 if ((comp
->ts
.type
== BT_DERIVED
&& comp
->attr
.pointer
)
810 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
811 && CLASS_DATA (comp
)->attr
.pointer
))
814 if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.allocatable
815 && (comp
->ts
.u
.derived
->f2k_derived
== NULL
816 || comp
->ts
.u
.derived
->f2k_derived
->finalizers
== NULL
)
817 && !has_finalizer_component (comp
->ts
.u
.derived
))
820 e
= gfc_copy_expr (expr
);
822 e
->ref
= ref
= gfc_get_ref ();
825 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
827 ref
->next
= gfc_get_ref ();
830 ref
->type
= REF_COMPONENT
;
831 ref
->u
.c
.sym
= derived
;
832 ref
->u
.c
.component
= comp
;
835 if (comp
->attr
.dimension
836 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
837 && CLASS_DATA (comp
)->attr
.dimension
))
839 ref
->next
= gfc_get_ref ();
840 ref
->next
->type
= REF_ARRAY
;
841 ref
->next
->u
.ar
.type
= AR_FULL
;
842 ref
->next
->u
.ar
.dimen
= 0;
843 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
845 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
848 /* Call DEALLOCATE (comp, stat=ignore). */
849 if (comp
->attr
.allocatable
850 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
851 && CLASS_DATA (comp
)->attr
.allocatable
))
853 gfc_code
*dealloc
, *block
= NULL
;
855 /* Add IF (fini_coarray). */
856 if (comp
->attr
.codimension
857 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
858 && CLASS_DATA (comp
)->attr
.allocatable
))
860 block
= XCNEW (gfc_code
);
863 (*code
)->next
= block
;
864 (*code
) = (*code
)->next
;
869 block
->loc
= gfc_current_locus
;
872 block
->block
= XCNEW (gfc_code
);
873 block
= block
->block
;
874 block
->loc
= gfc_current_locus
;
876 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
879 dealloc
= XCNEW (gfc_code
);
880 dealloc
->op
= EXEC_DEALLOCATE
;
881 dealloc
->loc
= gfc_current_locus
;
883 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
884 dealloc
->ext
.alloc
.list
->expr
= e
;
885 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
888 block
->next
= dealloc
;
891 (*code
)->next
= dealloc
;
892 (*code
) = (*code
)->next
;
897 else if (comp
->ts
.type
== BT_DERIVED
898 && comp
->ts
.u
.derived
->f2k_derived
899 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
901 /* Call FINAL_WRAPPER (comp); */
902 gfc_code
*final_wrap
;
906 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
907 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
908 if (strcmp (c
->name
, "_final") == 0)
912 final_wrap
= XCNEW (gfc_code
);
913 final_wrap
->op
= EXEC_CALL
;
914 final_wrap
->loc
= gfc_current_locus
;
915 final_wrap
->loc
= gfc_current_locus
;
916 final_wrap
->symtree
= c
->initializer
->symtree
;
917 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
918 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
919 final_wrap
->ext
.actual
->expr
= e
;
923 (*code
)->next
= final_wrap
;
924 (*code
) = (*code
)->next
;
927 (*code
) = final_wrap
;
933 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
934 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
940 /* Generate code equivalent to
941 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
942 + offset, c_ptr), ptr). */
945 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
946 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
949 gfc_expr
*expr
, *expr2
;
952 block
= XCNEW (gfc_code
);
953 block
->op
= EXEC_CALL
;
954 block
->loc
= gfc_current_locus
;
955 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
956 block
->resolved_sym
= block
->symtree
->n
.sym
;
957 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
958 block
->resolved_sym
->attr
.intrinsic
= 1;
959 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
960 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
961 gfc_commit_symbol (block
->resolved_sym
);
963 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
964 block
->ext
.actual
= gfc_get_actual_arglist ();
965 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
966 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
969 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
971 /* TRANSFER's first argument: C_LOC (array). */
972 expr
= gfc_get_expr ();
973 expr
->expr_type
= EXPR_FUNCTION
;
974 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
975 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
976 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
977 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
978 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
979 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
980 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
981 expr
->value
.function
.actual
->expr
982 = gfc_lval_expr_from_sym (array
);
983 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
984 gfc_commit_symbol (expr
->symtree
->n
.sym
);
985 expr
->ts
.type
= BT_INTEGER
;
986 expr
->ts
.kind
= gfc_index_integer_kind
;
989 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
990 gfc_current_locus
, 2, expr
,
991 gfc_get_int_expr (gfc_index_integer_kind
,
993 expr2
->ts
.type
= BT_INTEGER
;
994 expr2
->ts
.kind
= gfc_index_integer_kind
;
996 /* <array addr> + <offset>. */
997 block
->ext
.actual
->expr
= gfc_get_expr ();
998 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
999 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1000 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1001 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1002 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1004 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1005 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1006 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1007 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1013 /* Calculates the offset to the (idx+1)th element of an array, taking the
1014 stride into account. It generates the code:
1017 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1019 offset = offset * byte_stride. */
1022 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1023 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1024 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1025 gfc_code
*block
, gfc_namespace
*sub_ns
)
1028 gfc_expr
*expr
, *expr2
;
1031 block
->next
= XCNEW (gfc_code
);
1032 block
= block
->next
;
1033 block
->op
= EXEC_ASSIGN
;
1034 block
->loc
= gfc_current_locus
;
1035 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1036 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1039 iter
= gfc_get_iterator ();
1040 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1041 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1042 iter
->end
= gfc_copy_expr (rank
);
1043 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1044 block
->next
= XCNEW (gfc_code
);
1045 block
= block
->next
;
1046 block
->op
= EXEC_DO
;
1047 block
->loc
= gfc_current_locus
;
1048 block
->ext
.iterator
= iter
;
1049 block
->block
= gfc_get_code ();
1050 block
->block
->op
= EXEC_DO
;
1052 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1055 /* mod (idx, sizes(idx2)). */
1056 expr
= gfc_lval_expr_from_sym (sizes
);
1057 expr
->ref
= gfc_get_ref ();
1058 expr
->ref
->type
= REF_ARRAY
;
1059 expr
->ref
->u
.ar
.as
= sizes
->as
;
1060 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1061 expr
->ref
->u
.ar
.dimen
= 1;
1062 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1063 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1065 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1066 gfc_current_locus
, 2,
1067 gfc_lval_expr_from_sym (idx
), expr
);
1070 /* (...) / sizes(idx2-1). */
1071 expr2
= gfc_get_expr ();
1072 expr2
->expr_type
= EXPR_OP
;
1073 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1074 expr2
->value
.op
.op1
= expr
;
1075 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1076 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1077 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1078 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1079 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1080 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1081 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1082 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1083 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1084 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1085 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1086 = gfc_lval_expr_from_sym (idx2
);
1087 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1088 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1089 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1090 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1091 expr2
->ts
= idx
->ts
;
1093 /* ... * strides(idx2). */
1094 expr
= gfc_get_expr ();
1095 expr
->expr_type
= EXPR_OP
;
1096 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1097 expr
->value
.op
.op1
= expr2
;
1098 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1099 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1100 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1101 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1102 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1103 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1104 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1105 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1108 /* offset = offset + ... */
1109 block
->block
->next
= XCNEW (gfc_code
);
1110 block
->block
->next
->op
= EXEC_ASSIGN
;
1111 block
->block
->next
->loc
= gfc_current_locus
;
1112 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1113 block
->block
->next
->expr2
= gfc_get_expr ();
1114 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1115 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1116 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1117 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1118 block
->block
->next
->expr2
->ts
= idx
->ts
;
1120 /* After the loop: offset = offset * byte_stride. */
1121 block
->next
= XCNEW (gfc_code
);
1122 block
= block
->next
;
1123 block
->op
= EXEC_ASSIGN
;
1124 block
->loc
= gfc_current_locus
;
1125 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1126 block
->expr2
= gfc_get_expr ();
1127 block
->expr2
->expr_type
= EXPR_OP
;
1128 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1129 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1130 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1131 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1136 /* Insert code of the following form:
1139 integer(c_intptr_t) :: i
1141 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1142 && (is_contiguous || !final_rank3->attr.contiguous
1143 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1144 || 0 == STORAGE_SIZE (array)) then
1145 call final_rank3 (array)
1148 integer(c_intptr_t) :: offset, j
1149 type(t) :: tmp(shape (array))
1151 do i = 0, size (array)-1
1152 offset = obtain_offset(i, strides, sizes, byte_stride)
1153 addr = transfer (c_loc (array), addr) + offset
1154 call c_f_pointer (transfer (addr, cptr), ptr)
1156 addr = transfer (c_loc (tmp), addr)
1157 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1158 call c_f_pointer (transfer (addr, cptr), ptr2)
1161 call final_rank3 (tmp)
1167 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1168 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1169 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1171 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1172 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1173 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1174 gfc_namespace
*sub_ns
)
1176 gfc_symbol
*tmp_array
, *ptr2
;
1177 gfc_expr
*size_expr
, *offset2
, *expr
;
1183 block
->next
= XCNEW (gfc_code
);
1184 block
= block
->next
;
1185 block
->loc
= gfc_current_locus
;
1186 block
->op
= EXEC_IF
;
1188 block
->block
= XCNEW (gfc_code
);
1189 block
= block
->block
;
1190 block
->loc
= gfc_current_locus
;
1191 block
->op
= EXEC_IF
;
1193 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1194 size_expr
= gfc_get_expr ();
1195 size_expr
->where
= gfc_current_locus
;
1196 size_expr
->expr_type
= EXPR_OP
;
1197 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1199 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1200 size_expr
->value
.op
.op1
1201 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1202 "storage_size", gfc_current_locus
, 2,
1203 gfc_lval_expr_from_sym (array
));
1204 gfc_get_int_expr (gfc_index_integer_kind
,
1207 /* NUMERIC_STORAGE_SIZE. */
1208 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1209 gfc_character_storage_size
);
1210 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1211 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1213 /* IF condition: (stride == size_expr
1214 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1216 || 0 == size_expr. */
1217 block
->expr1
= gfc_get_expr ();
1218 block
->expr1
->expr_type
= EXPR_FUNCTION
;
1219 block
->expr1
->ts
.type
= BT_LOGICAL
;
1220 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1221 block
->expr1
->expr_type
= EXPR_OP
;
1222 block
->expr1
->where
= gfc_current_locus
;
1224 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1226 /* byte_stride == size_expr */
1227 expr
= gfc_get_expr ();
1228 expr
->ts
.type
= BT_LOGICAL
;
1229 expr
->ts
.kind
= gfc_default_logical_kind
;
1230 expr
->expr_type
= EXPR_OP
;
1231 expr
->where
= gfc_current_locus
;
1232 expr
->value
.op
.op
= INTRINSIC_EQ
;
1234 = gfc_lval_expr_from_sym (byte_stride
);
1235 expr
->value
.op
.op2
= size_expr
;
1237 /* If strides aren't allowd (not assumed shape or CONTIGUOUS),
1238 add is_contiguous check. */
1239 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1240 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1243 expr2
= gfc_get_expr ();
1244 expr2
->ts
.type
= BT_LOGICAL
;
1245 expr2
->ts
.kind
= gfc_default_logical_kind
;
1246 expr2
->expr_type
= EXPR_OP
;
1247 expr2
->where
= gfc_current_locus
;
1248 expr2
->value
.op
.op
= INTRINSIC_AND
;
1249 expr2
->value
.op
.op1
= expr
;
1250 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1254 block
->expr1
->value
.op
.op1
= expr
;
1256 /* 0 == size_expr */
1257 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1258 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1259 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1260 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1261 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1262 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1263 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1264 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1265 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1267 /* IF body: call final subroutine. */
1268 block
->next
= XCNEW (gfc_code
);
1269 block
->next
->op
= EXEC_CALL
;
1270 block
->next
->loc
= gfc_current_locus
;
1271 block
->next
->symtree
= fini
->proc_tree
;
1272 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1273 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1274 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1278 block
->block
= XCNEW (gfc_code
);
1279 block
= block
->block
;
1280 block
->loc
= gfc_current_locus
;
1281 block
->op
= EXEC_IF
;
1283 block
->next
= XCNEW (gfc_code
);
1284 block
= block
->next
;
1286 /* BLOCK ... END BLOCK. */
1287 block
->op
= EXEC_BLOCK
;
1288 block
->loc
= gfc_current_locus
;
1289 ns
= gfc_build_block_ns (sub_ns
);
1290 block
->ext
.block
.ns
= ns
;
1291 block
->ext
.block
.assoc
= NULL
;
1293 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1294 ptr2
->ts
.type
= BT_DERIVED
;
1295 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1296 ptr2
->attr
.flavor
= FL_VARIABLE
;
1297 ptr2
->attr
.pointer
= 1;
1298 ptr2
->attr
.artificial
= 1;
1299 gfc_set_sym_referenced (ptr2
);
1300 gfc_commit_symbol (ptr2
);
1302 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1303 tmp_array
->ts
.type
= BT_DERIVED
;
1304 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1305 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1306 tmp_array
->attr
.dimension
= 1;
1307 tmp_array
->attr
.artificial
= 1;
1308 tmp_array
->as
= gfc_get_array_spec();
1309 tmp_array
->attr
.intent
= INTENT_INOUT
;
1310 tmp_array
->as
->type
= AS_EXPLICIT
;
1311 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1313 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1315 gfc_expr
*shape_expr
;
1316 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1318 /* SIZE (array, dim=i+1, kind=default_kind). */
1320 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1321 gfc_current_locus
, 3,
1322 gfc_lval_expr_from_sym (array
),
1323 gfc_get_int_expr (gfc_default_integer_kind
,
1325 gfc_get_int_expr (gfc_default_integer_kind
,
1327 tmp_array
->as
->upper
[i
] = shape_expr
;
1329 gfc_set_sym_referenced (tmp_array
);
1330 gfc_commit_symbol (tmp_array
);
1333 iter
= gfc_get_iterator ();
1334 iter
->var
= gfc_lval_expr_from_sym (idx
);
1335 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1336 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1337 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1339 block
= XCNEW (gfc_code
);
1341 block
->op
= EXEC_DO
;
1342 block
->loc
= gfc_current_locus
;
1343 block
->ext
.iterator
= iter
;
1344 block
->block
= gfc_get_code ();
1345 block
->block
->op
= EXEC_DO
;
1347 /* Offset calculation for the new array: idx * size of type (in bytes). */
1348 offset2
= gfc_get_expr ();
1349 offset2
= block
->ext
.actual
->expr
;
1350 offset2
->expr_type
= EXPR_OP
;
1351 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1352 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1353 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1354 offset2
->ts
= byte_stride
->ts
;
1356 /* Offset calculation of "array". */
1357 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1358 byte_stride
, rank
, block
->block
, sub_ns
);
1361 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1362 + idx * stride, c_ptr), ptr). */
1363 block2
->next
= finalization_scalarizer (array
, ptr
,
1364 gfc_lval_expr_from_sym (offset
),
1366 block2
= block2
->next
;
1367 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1370 block2
->next
= XCNEW (gfc_code
);
1371 block2
->next
->op
= EXEC_ASSIGN
;
1372 block2
->next
->loc
= gfc_current_locus
;
1373 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1374 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr
);
1376 /* Call now the user's final subroutine. */
1377 block
->next
= XCNEW (gfc_code
);
1378 block
= block
->next
;
1379 block
->op
= EXEC_CALL
;
1380 block
->loc
= gfc_current_locus
;
1381 block
->symtree
= fini
->proc_tree
;
1382 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1383 block
->ext
.actual
= gfc_get_actual_arglist ();
1384 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1386 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1392 iter
= gfc_get_iterator ();
1393 iter
->var
= gfc_lval_expr_from_sym (idx
);
1394 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1395 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1396 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1398 block
->next
= XCNEW (gfc_code
);
1399 block
= block
->next
;
1400 block
->op
= EXEC_DO
;
1401 block
->loc
= gfc_current_locus
;
1402 block
->ext
.iterator
= iter
;
1403 block
->block
= gfc_get_code ();
1404 block
->block
->op
= EXEC_DO
;
1406 /* Offset calculation of "array". */
1407 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1408 byte_stride
, rank
, block
->block
, sub_ns
);
1411 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1412 + offset, c_ptr), ptr). */
1413 block2
->next
= finalization_scalarizer (array
, ptr
,
1414 gfc_lval_expr_from_sym (offset
),
1416 block2
= block2
->next
;
1417 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1418 block2
= block2
->next
;
1421 block2
->next
= XCNEW (gfc_code
);
1422 block2
->next
->op
= EXEC_ASSIGN
;
1423 block2
->next
->loc
= gfc_current_locus
;
1424 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1425 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1429 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1430 derived type "derived". The function first calls the approriate FINAL
1431 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1432 components (but not the inherited ones). Last, it calls the wrapper
1433 subroutine of the parent. The generated wrapper procedure takes as argument
1434 an assumed-rank array.
1435 If neither allocatable components nor FINAL subroutines exists, the vtab
1436 will contain a NULL pointer.
1437 The generated function has the form
1438 _final(assumed-rank array, stride, skip_corarray)
1439 where the array has to be contiguous (except of the lowest dimension). The
1440 stride (in bytes) is used to allow different sizes for ancestor types by
1441 skipping over the additionally added components in the scalarizer. If
1442 "fini_coarray" is false, coarray components are not finalized to allow for
1443 the correct semantic with intrinsic assignment. */
1446 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1447 const char *tname
, gfc_component
*vtab_final
)
1449 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1450 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1451 gfc_component
*comp
;
1452 gfc_namespace
*sub_ns
;
1453 gfc_code
*last_code
, *block
;
1454 char name
[GFC_MAX_SYMBOL_LEN
+1];
1455 bool finalizable_comp
= false;
1456 bool expr_null_wrapper
= false;
1457 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1460 /* Search for the ancestor's finalizers. */
1461 if (derived
->attr
.extension
&& derived
->components
1462 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1463 || has_finalizer_component (derived
)))
1466 gfc_component
*comp
;
1468 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1469 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1470 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1472 ancestor_wrapper
= comp
->initializer
;
1477 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1478 components: Return a NULL() expression; we defer this a bit to have have
1479 an interface declaration. */
1480 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1481 && !derived
->attr
.alloc_comp
1482 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1483 && !has_finalizer_component (derived
))
1484 expr_null_wrapper
= true;
1486 /* Check whether there are new allocatable components. */
1487 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1489 if (comp
== derived
->components
&& derived
->attr
.extension
1490 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1493 if (comp
->ts
.type
!= BT_CLASS
&& !comp
->attr
.pointer
1494 && (comp
->attr
.allocatable
1495 || (comp
->ts
.type
== BT_DERIVED
1496 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1497 || has_finalizer_component (comp
->ts
.u
.derived
)
1498 || (comp
->ts
.u
.derived
->f2k_derived
1499 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))))
1500 finalizable_comp
= true;
1501 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1502 && CLASS_DATA (comp
)->attr
.allocatable
)
1503 finalizable_comp
= true;
1506 /* If there is no new finalizer and no new allocatable, return with
1507 an expr to the ancestor's one. */
1508 if (!expr_null_wrapper
&& !finalizable_comp
1509 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1511 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1512 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1513 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1514 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1518 /* We now create a wrapper, which does the following:
1519 1. Call the suitable finalization subroutine for this type
1520 2. Loop over all noninherited allocatable components and noninherited
1521 components with allocatable components and DEALLOCATE those; this will
1522 take care of finalizers, coarray deregistering and allocatable
1524 3. Call the ancestor's finalizer. */
1526 /* Declare the wrapper function; it takes an assumed-rank array
1527 and a VALUE logical as arguments. */
1529 /* Set up the namespace. */
1530 sub_ns
= gfc_get_namespace (ns
, 0);
1531 sub_ns
->sibling
= ns
->contained
;
1532 if (!expr_null_wrapper
)
1533 ns
->contained
= sub_ns
;
1534 sub_ns
->resolved
= 1;
1536 /* Set up the procedure symbol. */
1537 sprintf (name
, "__final_%s", tname
);
1538 gfc_get_symbol (name
, sub_ns
, &final
);
1539 sub_ns
->proc_name
= final
;
1540 final
->attr
.flavor
= FL_PROCEDURE
;
1541 final
->attr
.function
= 1;
1542 final
->attr
.pure
= 0;
1543 final
->result
= final
;
1544 final
->ts
.type
= BT_INTEGER
;
1546 final
->attr
.artificial
= 1;
1547 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1548 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1549 final
->module
= ns
->proc_name
->name
;
1550 gfc_set_sym_referenced (final
);
1551 gfc_commit_symbol (final
);
1553 /* Set up formal argument. */
1554 gfc_get_symbol ("array", sub_ns
, &array
);
1555 array
->ts
.type
= BT_DERIVED
;
1556 array
->ts
.u
.derived
= derived
;
1557 array
->attr
.flavor
= FL_VARIABLE
;
1558 array
->attr
.dummy
= 1;
1559 array
->attr
.contiguous
= 1;
1560 array
->attr
.dimension
= 1;
1561 array
->attr
.artificial
= 1;
1562 array
->as
= gfc_get_array_spec();
1563 array
->as
->type
= AS_ASSUMED_RANK
;
1564 array
->as
->rank
= -1;
1565 array
->attr
.intent
= INTENT_INOUT
;
1566 gfc_set_sym_referenced (array
);
1567 final
->formal
= gfc_get_formal_arglist ();
1568 final
->formal
->sym
= array
;
1569 gfc_commit_symbol (array
);
1571 /* Set up formal argument. */
1572 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1573 byte_stride
->ts
.type
= BT_INTEGER
;
1574 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1575 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1576 byte_stride
->attr
.dummy
= 1;
1577 byte_stride
->attr
.value
= 1;
1578 byte_stride
->attr
.artificial
= 1;
1579 gfc_set_sym_referenced (byte_stride
);
1580 final
->formal
->next
= gfc_get_formal_arglist ();
1581 final
->formal
->next
->sym
= byte_stride
;
1582 gfc_commit_symbol (byte_stride
);
1584 /* Set up formal argument. */
1585 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1586 fini_coarray
->ts
.type
= BT_LOGICAL
;
1587 fini_coarray
->ts
.kind
= 1;
1588 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1589 fini_coarray
->attr
.dummy
= 1;
1590 fini_coarray
->attr
.value
= 1;
1591 fini_coarray
->attr
.artificial
= 1;
1592 gfc_set_sym_referenced (fini_coarray
);
1593 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1594 final
->formal
->next
->next
->sym
= fini_coarray
;
1595 gfc_commit_symbol (fini_coarray
);
1597 /* Return with a NULL() expression but with an interface which has
1598 the formal arguments. */
1599 if (expr_null_wrapper
)
1601 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1602 vtab_final
->ts
.interface
= final
;
1606 /* Local variables. */
1608 gfc_get_symbol ("idx", sub_ns
, &idx
);
1609 idx
->ts
.type
= BT_INTEGER
;
1610 idx
->ts
.kind
= gfc_index_integer_kind
;
1611 idx
->attr
.flavor
= FL_VARIABLE
;
1612 idx
->attr
.artificial
= 1;
1613 gfc_set_sym_referenced (idx
);
1614 gfc_commit_symbol (idx
);
1616 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1617 idx2
->ts
.type
= BT_INTEGER
;
1618 idx2
->ts
.kind
= gfc_index_integer_kind
;
1619 idx2
->attr
.flavor
= FL_VARIABLE
;
1620 idx2
->attr
.artificial
= 1;
1621 gfc_set_sym_referenced (idx2
);
1622 gfc_commit_symbol (idx2
);
1624 gfc_get_symbol ("offset", sub_ns
, &offset
);
1625 offset
->ts
.type
= BT_INTEGER
;
1626 offset
->ts
.kind
= gfc_index_integer_kind
;
1627 offset
->attr
.flavor
= FL_VARIABLE
;
1628 offset
->attr
.artificial
= 1;
1629 gfc_set_sym_referenced (offset
);
1630 gfc_commit_symbol (offset
);
1632 /* Create RANK expression. */
1633 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1634 gfc_current_locus
, 1,
1635 gfc_lval_expr_from_sym (array
));
1636 gfc_convert_type (rank
, &idx
->ts
, 2);
1638 /* Create is_contiguous variable. */
1639 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1640 is_contiguous
->ts
.type
= BT_LOGICAL
;
1641 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1642 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1643 is_contiguous
->attr
.artificial
= 1;
1644 gfc_set_sym_referenced (is_contiguous
);
1645 gfc_commit_symbol (is_contiguous
);
1647 /* Create "sizes(0..rank)" variable, which contains the multiplied
1648 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1649 sizes(2) = sizes(1) * extent(dim=2) etc. */
1650 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1651 sizes
->ts
.type
= BT_INTEGER
;
1652 sizes
->ts
.kind
= gfc_index_integer_kind
;
1653 sizes
->attr
.flavor
= FL_VARIABLE
;
1654 sizes
->attr
.dimension
= 1;
1655 sizes
->attr
.artificial
= 1;
1656 sizes
->as
= gfc_get_array_spec();
1657 sizes
->attr
.intent
= INTENT_INOUT
;
1658 sizes
->as
->type
= AS_EXPLICIT
;
1659 sizes
->as
->rank
= 1;
1660 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1661 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1662 gfc_set_sym_referenced (sizes
);
1663 gfc_commit_symbol (sizes
);
1665 /* Create "strides(1..rank)" variable, which contains the strides per
1667 gfc_get_symbol ("strides", sub_ns
, &strides
);
1668 strides
->ts
.type
= BT_INTEGER
;
1669 strides
->ts
.kind
= gfc_index_integer_kind
;
1670 strides
->attr
.flavor
= FL_VARIABLE
;
1671 strides
->attr
.dimension
= 1;
1672 strides
->attr
.artificial
= 1;
1673 strides
->as
= gfc_get_array_spec();
1674 strides
->attr
.intent
= INTENT_INOUT
;
1675 strides
->as
->type
= AS_EXPLICIT
;
1676 strides
->as
->rank
= 1;
1677 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1678 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1679 gfc_set_sym_referenced (strides
);
1680 gfc_commit_symbol (strides
);
1683 /* Set return value to 0. */
1684 last_code
= XCNEW (gfc_code
);
1685 last_code
->op
= EXEC_ASSIGN
;
1686 last_code
->loc
= gfc_current_locus
;
1687 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1688 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1689 sub_ns
->code
= last_code
;
1691 /* Set: is_contiguous = .true. */
1692 last_code
->next
= XCNEW (gfc_code
);
1693 last_code
= last_code
->next
;
1694 last_code
->op
= EXEC_ASSIGN
;
1695 last_code
->loc
= gfc_current_locus
;
1696 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1697 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1698 &gfc_current_locus
, true);
1700 /* Set: sizes(0) = 1. */
1701 last_code
->next
= XCNEW (gfc_code
);
1702 last_code
= last_code
->next
;
1703 last_code
->op
= EXEC_ASSIGN
;
1704 last_code
->loc
= gfc_current_locus
;
1705 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1706 last_code
->expr1
->ref
= gfc_get_ref ();
1707 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1708 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1709 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1710 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1711 last_code
->expr1
->ref
->u
.ar
.start
[0]
1712 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1713 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1714 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1718 strides(idx) = _F._stride (array, dim=idx)
1719 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1720 if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
1724 iter
= gfc_get_iterator ();
1725 iter
->var
= gfc_lval_expr_from_sym (idx
);
1726 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1727 iter
->end
= gfc_copy_expr (rank
);
1728 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1729 last_code
->next
= XCNEW (gfc_code
);
1730 last_code
= last_code
->next
;
1731 last_code
->op
= EXEC_DO
;
1732 last_code
->loc
= gfc_current_locus
;
1733 last_code
->ext
.iterator
= iter
;
1734 last_code
->block
= gfc_get_code ();
1735 last_code
->block
->op
= EXEC_DO
;
1737 /* strides(idx) = _F._stride(array,dim=idx). */
1738 last_code
->block
->next
= XCNEW (gfc_code
);
1739 block
= last_code
->block
->next
;
1740 block
->op
= EXEC_ASSIGN
;
1741 block
->loc
= gfc_current_locus
;
1743 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1744 block
->expr1
->ref
= gfc_get_ref ();
1745 block
->expr1
->ref
->type
= REF_ARRAY
;
1746 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1747 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1748 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1749 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1750 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1752 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1753 gfc_current_locus
, 2,
1754 gfc_lval_expr_from_sym (array
),
1755 gfc_lval_expr_from_sym (idx
));
1757 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1758 block
->next
= XCNEW (gfc_code
);
1759 block
= block
->next
;
1760 block
->op
= EXEC_ASSIGN
;
1761 block
->loc
= gfc_current_locus
;
1763 /* sizes(idx) = ... */
1764 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1765 block
->expr1
->ref
= gfc_get_ref ();
1766 block
->expr1
->ref
->type
= REF_ARRAY
;
1767 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1768 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1769 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1770 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1771 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1773 block
->expr2
= gfc_get_expr ();
1774 block
->expr2
->expr_type
= EXPR_OP
;
1775 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1778 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1779 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1780 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1781 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1782 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1783 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1784 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1785 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1786 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1787 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1788 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1789 = gfc_lval_expr_from_sym (idx
);
1790 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1791 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1792 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1793 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1795 /* size(array, dim=idx, kind=index_kind). */
1796 block
->expr2
->value
.op
.op2
1797 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1798 gfc_current_locus
, 3,
1799 gfc_lval_expr_from_sym (array
),
1800 gfc_lval_expr_from_sym (idx
),
1801 gfc_get_int_expr (gfc_index_integer_kind
,
1803 block
->expr2
->ts
= idx
->ts
;
1805 /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
1806 block
->next
= XCNEW (gfc_code
);
1807 block
= block
->next
;
1808 block
->loc
= gfc_current_locus
;
1809 block
->op
= EXEC_IF
;
1811 block
->block
= XCNEW (gfc_code
);
1812 block
= block
->block
;
1813 block
->loc
= gfc_current_locus
;
1814 block
->op
= EXEC_IF
;
1816 /* if condition: strides(idx) /= sizes(idx-1). */
1817 block
->expr1
= gfc_get_expr ();
1818 block
->expr1
->ts
.type
= BT_LOGICAL
;
1819 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1820 block
->expr1
->expr_type
= EXPR_OP
;
1821 block
->expr1
->where
= gfc_current_locus
;
1822 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1824 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1825 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1826 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1827 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1828 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1829 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1830 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1831 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1833 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1834 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1835 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1836 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1837 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1838 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1839 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1840 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1841 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1842 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1843 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1844 = gfc_lval_expr_from_sym (idx
);
1845 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1846 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1847 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1848 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1850 /* if body: is_contiguous = .false. */
1851 block
->next
= XCNEW (gfc_code
);
1852 block
= block
->next
;
1853 block
->op
= EXEC_ASSIGN
;
1854 block
->loc
= gfc_current_locus
;
1855 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1856 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1857 &gfc_current_locus
, false);
1859 /* Obtain the size (number of elements) of "array" MINUS ONE,
1860 which is used in the scalarization. */
1861 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1862 nelem
->ts
.type
= BT_INTEGER
;
1863 nelem
->ts
.kind
= gfc_index_integer_kind
;
1864 nelem
->attr
.flavor
= FL_VARIABLE
;
1865 nelem
->attr
.artificial
= 1;
1866 gfc_set_sym_referenced (nelem
);
1867 gfc_commit_symbol (nelem
);
1869 /* nelem = sizes (rank) - 1. */
1870 last_code
->next
= XCNEW (gfc_code
);
1871 last_code
= last_code
->next
;
1872 last_code
->op
= EXEC_ASSIGN
;
1873 last_code
->loc
= gfc_current_locus
;
1875 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1877 last_code
->expr2
= gfc_get_expr ();
1878 last_code
->expr2
->expr_type
= EXPR_OP
;
1879 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1880 last_code
->expr2
->value
.op
.op2
1881 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1882 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1884 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1885 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1886 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1887 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1888 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1889 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1890 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1891 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1893 /* Call final subroutines. We now generate code like:
1895 integer, pointer :: ptr
1897 integer(c_intptr_t) :: i, addr
1899 select case (rank (array))
1901 ! If needed, the array is packed
1902 call final_rank3 (array)
1904 do i = 0, size (array)-1
1905 addr = transfer (c_loc (array), addr) + i * stride
1906 call c_f_pointer (transfer (addr, cptr), ptr)
1907 call elemental_final (ptr)
1911 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1913 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1915 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1916 ptr
->ts
.type
= BT_DERIVED
;
1917 ptr
->ts
.u
.derived
= derived
;
1918 ptr
->attr
.flavor
= FL_VARIABLE
;
1919 ptr
->attr
.pointer
= 1;
1920 ptr
->attr
.artificial
= 1;
1921 gfc_set_sym_referenced (ptr
);
1922 gfc_commit_symbol (ptr
);
1924 /* SELECT CASE (RANK (array)). */
1925 last_code
->next
= XCNEW (gfc_code
);
1926 last_code
= last_code
->next
;
1927 last_code
->op
= EXEC_SELECT
;
1928 last_code
->loc
= gfc_current_locus
;
1929 last_code
->expr1
= gfc_copy_expr (rank
);
1932 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1934 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1940 /* CASE (fini_rank). */
1943 block
->block
= XCNEW (gfc_code
);
1944 block
= block
->block
;
1948 block
= XCNEW (gfc_code
);
1949 last_code
->block
= block
;
1951 block
->loc
= gfc_current_locus
;
1952 block
->op
= EXEC_SELECT
;
1953 block
->ext
.block
.case_list
= gfc_get_case ();
1954 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1955 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1956 block
->ext
.block
.case_list
->low
1957 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1958 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1960 block
->ext
.block
.case_list
->low
1961 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1962 block
->ext
.block
.case_list
->high
1963 = block
->ext
.block
.case_list
->low
;
1965 /* CALL fini_rank (array) - possibly with packing. */
1966 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1967 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1968 idx
, ptr
, nelem
, strides
,
1969 sizes
, idx2
, offset
, is_contiguous
,
1973 block
->next
= XCNEW (gfc_code
);
1974 block
->next
->op
= EXEC_CALL
;
1975 block
->next
->loc
= gfc_current_locus
;
1976 block
->next
->symtree
= fini
->proc_tree
;
1977 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1978 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1979 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1983 /* Elemental call - scalarized. */
1989 block
->block
= XCNEW (gfc_code
);
1990 block
= block
->block
;
1994 block
= XCNEW (gfc_code
);
1995 last_code
->block
= block
;
1997 block
->loc
= gfc_current_locus
;
1998 block
->op
= EXEC_SELECT
;
1999 block
->ext
.block
.case_list
= gfc_get_case ();
2002 iter
= gfc_get_iterator ();
2003 iter
->var
= gfc_lval_expr_from_sym (idx
);
2004 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2005 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2006 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2007 block
->next
= XCNEW (gfc_code
);
2008 block
= block
->next
;
2009 block
->op
= EXEC_DO
;
2010 block
->loc
= gfc_current_locus
;
2011 block
->ext
.iterator
= iter
;
2012 block
->block
= gfc_get_code ();
2013 block
->block
->op
= EXEC_DO
;
2015 /* Offset calculation. */
2016 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2017 byte_stride
, rank
, block
->block
,
2021 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2022 + offset, c_ptr), ptr). */
2024 = finalization_scalarizer (array
, ptr
,
2025 gfc_lval_expr_from_sym (offset
),
2027 block
= block
->next
;
2029 /* CALL final_elemental (array). */
2030 block
->next
= XCNEW (gfc_code
);
2031 block
= block
->next
;
2032 block
->op
= EXEC_CALL
;
2033 block
->loc
= gfc_current_locus
;
2034 block
->symtree
= fini_elem
->proc_tree
;
2035 block
->resolved_sym
= fini_elem
->proc_sym
;
2036 block
->ext
.actual
= gfc_get_actual_arglist ();
2037 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2041 /* Finalize and deallocate allocatable components. The same manual
2042 scalarization is used as above. */
2044 if (finalizable_comp
)
2047 gfc_code
*block
= NULL
;
2051 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2052 ptr
->ts
.type
= BT_DERIVED
;
2053 ptr
->ts
.u
.derived
= derived
;
2054 ptr
->attr
.flavor
= FL_VARIABLE
;
2055 ptr
->attr
.pointer
= 1;
2056 ptr
->attr
.artificial
= 1;
2057 gfc_set_sym_referenced (ptr
);
2058 gfc_commit_symbol (ptr
);
2061 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2062 stat
->attr
.flavor
= FL_VARIABLE
;
2063 stat
->attr
.artificial
= 1;
2064 stat
->ts
.type
= BT_INTEGER
;
2065 stat
->ts
.kind
= gfc_default_integer_kind
;
2066 gfc_set_sym_referenced (stat
);
2067 gfc_commit_symbol (stat
);
2070 iter
= gfc_get_iterator ();
2071 iter
->var
= gfc_lval_expr_from_sym (idx
);
2072 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2073 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2074 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2075 last_code
->next
= XCNEW (gfc_code
);
2076 last_code
= last_code
->next
;
2077 last_code
->op
= EXEC_DO
;
2078 last_code
->loc
= gfc_current_locus
;
2079 last_code
->ext
.iterator
= iter
;
2080 last_code
->block
= gfc_get_code ();
2081 last_code
->block
->op
= EXEC_DO
;
2083 /* Offset calculation. */
2084 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2085 byte_stride
, rank
, last_code
->block
,
2089 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2090 + idx * stride, c_ptr), ptr). */
2091 block
->next
= finalization_scalarizer (array
, ptr
,
2092 gfc_lval_expr_from_sym(offset
),
2094 block
= block
->next
;
2096 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2098 if (comp
== derived
->components
&& derived
->attr
.extension
2099 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2102 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2103 stat
, fini_coarray
, &block
);
2104 if (!last_code
->block
->next
)
2105 last_code
->block
->next
= block
;
2110 /* Call the finalizer of the ancestor. */
2111 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2113 last_code
->next
= XCNEW (gfc_code
);
2114 last_code
= last_code
->next
;
2115 last_code
->op
= EXEC_CALL
;
2116 last_code
->loc
= gfc_current_locus
;
2117 last_code
->symtree
= ancestor_wrapper
->symtree
;
2118 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2120 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2121 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2122 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2123 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2124 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2125 last_code
->ext
.actual
->next
->next
->expr
2126 = gfc_lval_expr_from_sym (fini_coarray
);
2129 gfc_free_expr (rank
);
2130 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2131 vtab_final
->ts
.interface
= final
;
2135 /* Add procedure pointers for all type-bound procedures to a vtab. */
2138 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2140 gfc_symbol
* super_type
;
2142 super_type
= gfc_get_derived_super_type (derived
);
2144 if (super_type
&& (super_type
!= derived
))
2146 /* Make sure that the PPCs appear in the same order as in the parent. */
2147 copy_vtab_proc_comps (super_type
, vtype
);
2148 /* Only needed to get the PPC initializers right. */
2149 add_procs_to_declared_vtab (super_type
, vtype
);
2152 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2153 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2155 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2156 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2160 /* Find or generate the symbol for a derived type's vtab. */
2163 gfc_find_derived_vtab (gfc_symbol
*derived
)
2166 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2167 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2169 /* Find the top-level namespace. */
2170 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2174 /* If the type is a class container, use the underlying derived type. */
2175 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2176 derived
= gfc_get_derived_super_type (derived
);
2180 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2182 get_unique_hashed_string (tname
, derived
);
2183 sprintf (name
, "__vtab_%s", tname
);
2185 /* Look for the vtab symbol in various namespaces. */
2186 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2188 gfc_find_symbol (name
, ns
, 0, &vtab
);
2190 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2194 gfc_get_symbol (name
, ns
, &vtab
);
2195 vtab
->ts
.type
= BT_DERIVED
;
2196 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2197 &gfc_current_locus
) == FAILURE
)
2199 vtab
->attr
.target
= 1;
2200 vtab
->attr
.save
= SAVE_IMPLICIT
;
2201 vtab
->attr
.vtab
= 1;
2202 vtab
->attr
.access
= ACCESS_PUBLIC
;
2203 gfc_set_sym_referenced (vtab
);
2204 sprintf (name
, "__vtype_%s", tname
);
2206 gfc_find_symbol (name
, ns
, 0, &vtype
);
2210 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2212 gfc_get_symbol (name
, ns
, &vtype
);
2213 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2214 NULL
, &gfc_current_locus
) == FAILURE
)
2216 vtype
->attr
.access
= ACCESS_PUBLIC
;
2217 vtype
->attr
.vtype
= 1;
2218 gfc_set_sym_referenced (vtype
);
2220 /* Add component '_hash'. */
2221 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2223 c
->ts
.type
= BT_INTEGER
;
2225 c
->attr
.access
= ACCESS_PRIVATE
;
2226 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2227 NULL
, derived
->hash_value
);
2229 /* Add component '_size'. */
2230 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2232 c
->ts
.type
= BT_INTEGER
;
2234 c
->attr
.access
= ACCESS_PRIVATE
;
2235 /* Remember the derived type in ts.u.derived,
2236 so that the correct initializer can be set later on
2237 (in gfc_conv_structure). */
2238 c
->ts
.u
.derived
= derived
;
2239 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2242 /* Add component _extends. */
2243 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2245 c
->attr
.pointer
= 1;
2246 c
->attr
.access
= ACCESS_PRIVATE
;
2247 if (!derived
->attr
.unlimited_polymorphic
)
2248 parent
= gfc_get_derived_super_type (derived
);
2254 parent_vtab
= gfc_find_derived_vtab (parent
);
2255 c
->ts
.type
= BT_DERIVED
;
2256 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2257 c
->initializer
= gfc_get_expr ();
2258 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2259 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2260 0, &c
->initializer
->symtree
);
2264 c
->ts
.type
= BT_DERIVED
;
2265 c
->ts
.u
.derived
= vtype
;
2266 c
->initializer
= gfc_get_null_expr (NULL
);
2269 if (!derived
->attr
.unlimited_polymorphic
2270 && derived
->components
== NULL
2271 && !derived
->attr
.zero_comp
)
2273 /* At this point an error must have occurred.
2274 Prevent further errors on the vtype components. */
2279 /* Add component _def_init. */
2280 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2282 c
->attr
.pointer
= 1;
2283 c
->attr
.artificial
= 1;
2284 c
->attr
.access
= ACCESS_PRIVATE
;
2285 c
->ts
.type
= BT_DERIVED
;
2286 c
->ts
.u
.derived
= derived
;
2287 if (derived
->attr
.unlimited_polymorphic
2288 || derived
->attr
.abstract
)
2289 c
->initializer
= gfc_get_null_expr (NULL
);
2292 /* Construct default initialization variable. */
2293 sprintf (name
, "__def_init_%s", tname
);
2294 gfc_get_symbol (name
, ns
, &def_init
);
2295 def_init
->attr
.target
= 1;
2296 def_init
->attr
.artificial
= 1;
2297 def_init
->attr
.save
= SAVE_IMPLICIT
;
2298 def_init
->attr
.access
= ACCESS_PUBLIC
;
2299 def_init
->attr
.flavor
= FL_VARIABLE
;
2300 gfc_set_sym_referenced (def_init
);
2301 def_init
->ts
.type
= BT_DERIVED
;
2302 def_init
->ts
.u
.derived
= derived
;
2303 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2305 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2308 /* Add component _copy. */
2309 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2311 c
->attr
.proc_pointer
= 1;
2312 c
->attr
.access
= ACCESS_PRIVATE
;
2313 c
->tb
= XCNEW (gfc_typebound_proc
);
2315 if (derived
->attr
.unlimited_polymorphic
2316 || derived
->attr
.abstract
)
2317 c
->initializer
= gfc_get_null_expr (NULL
);
2320 /* Set up namespace. */
2321 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2322 sub_ns
->sibling
= ns
->contained
;
2323 ns
->contained
= sub_ns
;
2324 sub_ns
->resolved
= 1;
2325 /* Set up procedure symbol. */
2326 sprintf (name
, "__copy_%s", tname
);
2327 gfc_get_symbol (name
, sub_ns
, ©
);
2328 sub_ns
->proc_name
= copy
;
2329 copy
->attr
.flavor
= FL_PROCEDURE
;
2330 copy
->attr
.subroutine
= 1;
2331 copy
->attr
.pure
= 1;
2332 copy
->attr
.artificial
= 1;
2333 copy
->attr
.if_source
= IFSRC_DECL
;
2334 /* This is elemental so that arrays are automatically
2335 treated correctly by the scalarizer. */
2336 copy
->attr
.elemental
= 1;
2337 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2338 copy
->module
= ns
->proc_name
->name
;
2339 gfc_set_sym_referenced (copy
);
2340 /* Set up formal arguments. */
2341 gfc_get_symbol ("src", sub_ns
, &src
);
2342 src
->ts
.type
= BT_DERIVED
;
2343 src
->ts
.u
.derived
= derived
;
2344 src
->attr
.flavor
= FL_VARIABLE
;
2345 src
->attr
.dummy
= 1;
2346 src
->attr
.artificial
= 1;
2347 src
->attr
.intent
= INTENT_IN
;
2348 gfc_set_sym_referenced (src
);
2349 copy
->formal
= gfc_get_formal_arglist ();
2350 copy
->formal
->sym
= src
;
2351 gfc_get_symbol ("dst", sub_ns
, &dst
);
2352 dst
->ts
.type
= BT_DERIVED
;
2353 dst
->ts
.u
.derived
= derived
;
2354 dst
->attr
.flavor
= FL_VARIABLE
;
2355 dst
->attr
.dummy
= 1;
2356 dst
->attr
.artificial
= 1;
2357 dst
->attr
.intent
= INTENT_OUT
;
2358 gfc_set_sym_referenced (dst
);
2359 copy
->formal
->next
= gfc_get_formal_arglist ();
2360 copy
->formal
->next
->sym
= dst
;
2362 sub_ns
->code
= gfc_get_code ();
2363 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2364 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2365 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2366 /* Set initializer. */
2367 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2368 c
->ts
.interface
= copy
;
2371 /* Add component _final, which contains a procedure pointer to
2372 a wrapper which handles both the freeing of allocatable
2373 components and the calls to finalization subroutines.
2374 Note: The actual wrapper function can only be generated
2375 at resolution time. */
2376 /* FIXME: Enable ABI-breaking "_final" generation. */
2379 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2381 c
->attr
.proc_pointer
= 1;
2382 c
->attr
.access
= ACCESS_PRIVATE
;
2383 c
->tb
= XCNEW (gfc_typebound_proc
);
2385 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2388 /* Add procedure pointers for type-bound procedures. */
2389 if (!derived
->attr
.unlimited_polymorphic
)
2390 add_procs_to_declared_vtab (derived
, vtype
);
2394 vtab
->ts
.u
.derived
= vtype
;
2395 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2402 /* It is unexpected to have some symbols added at resolution or code
2403 generation time. We commit the changes in order to keep a clean state. */
2406 gfc_commit_symbol (vtab
);
2408 gfc_commit_symbol (vtype
);
2410 gfc_commit_symbol (def_init
);
2412 gfc_commit_symbol (copy
);
2414 gfc_commit_symbol (src
);
2416 gfc_commit_symbol (dst
);
2419 gfc_undo_symbols ();
2425 /* Check if a derived type is finalizable. That is the case if it
2426 (1) has a FINAL subroutine or
2427 (2) has a nonpointer nonallocatable component of finalizable type.
2428 If it is finalizable, return an expression containing the
2429 finalization wrapper. */
2432 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2437 /* (1) Check for FINAL subroutines. */
2438 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2441 /* (2) Check for components of finalizable type. */
2442 for (c
= derived
->components
; c
; c
= c
->next
)
2443 if (c
->ts
.type
== BT_DERIVED
2444 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2445 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2451 /* Make sure vtab is generated. */
2452 vtab
= gfc_find_derived_vtab (derived
);
2455 /* Return finalizer expression. */
2456 gfc_component
*final
;
2457 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2458 gcc_assert (strcmp (final
->name
, "_final") == 0);
2459 gcc_assert (final
->initializer
2460 && final
->initializer
->expr_type
!= EXPR_NULL
);
2461 *final_expr
= final
->initializer
;
2467 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2468 need to support unlimited polymorphism. */
2471 gfc_find_intrinsic_vtab (gfc_typespec
*ts
)
2474 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2475 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2478 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2480 gfc_error ("TODO: Deferred character length variable at %C cannot "
2481 "yet be associated with unlimited polymorphic entities");
2485 if (ts
->type
== BT_UNKNOWN
)
2488 /* Sometimes the typespec is passed from a single call. */
2489 if (ts
->type
== BT_DERIVED
)
2490 return gfc_find_derived_vtab (ts
->u
.derived
);
2492 /* Find the top-level namespace. */
2493 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2497 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
2498 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2499 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2503 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2505 if (ts
->type
== BT_CHARACTER
)
2506 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2509 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2511 sprintf (name
, "__vtab_%s", tname
);
2513 /* Look for the vtab symbol in various namespaces. */
2514 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2516 gfc_find_symbol (name
, ns
, 0, &vtab
);
2520 gfc_get_symbol (name
, ns
, &vtab
);
2521 vtab
->ts
.type
= BT_DERIVED
;
2522 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2523 &gfc_current_locus
) == FAILURE
)
2525 vtab
->attr
.target
= 1;
2526 vtab
->attr
.save
= SAVE_IMPLICIT
;
2527 vtab
->attr
.vtab
= 1;
2528 vtab
->attr
.access
= ACCESS_PUBLIC
;
2529 gfc_set_sym_referenced (vtab
);
2530 sprintf (name
, "__vtype_%s", tname
);
2532 gfc_find_symbol (name
, ns
, 0, &vtype
);
2537 gfc_namespace
*sub_ns
;
2538 gfc_namespace
*contained
;
2540 gfc_get_symbol (name
, ns
, &vtype
);
2541 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2542 NULL
, &gfc_current_locus
) == FAILURE
)
2544 vtype
->attr
.access
= ACCESS_PUBLIC
;
2545 vtype
->attr
.vtype
= 1;
2546 gfc_set_sym_referenced (vtype
);
2548 /* Add component '_hash'. */
2549 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2551 c
->ts
.type
= BT_INTEGER
;
2553 c
->attr
.access
= ACCESS_PRIVATE
;
2554 hash
= gfc_intrinsic_hash_value (ts
);
2555 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2558 /* Add component '_size'. */
2559 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2561 c
->ts
.type
= BT_INTEGER
;
2563 c
->attr
.access
= ACCESS_PRIVATE
;
2564 if (ts
->type
== BT_CHARACTER
)
2565 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2566 NULL
, charlen
*ts
->kind
);
2568 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2571 /* Add component _extends. */
2572 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2574 c
->attr
.pointer
= 1;
2575 c
->attr
.access
= ACCESS_PRIVATE
;
2576 c
->ts
.type
= BT_VOID
;
2577 c
->initializer
= gfc_get_null_expr (NULL
);
2579 /* Add component _def_init. */
2580 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2582 c
->attr
.pointer
= 1;
2583 c
->attr
.access
= ACCESS_PRIVATE
;
2584 c
->ts
.type
= BT_VOID
;
2585 c
->initializer
= gfc_get_null_expr (NULL
);
2587 /* Add component _copy. */
2588 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2590 c
->attr
.proc_pointer
= 1;
2591 c
->attr
.access
= ACCESS_PRIVATE
;
2592 c
->tb
= XCNEW (gfc_typebound_proc
);
2595 /* Check to see if copy function already exists. Note
2596 that this is only used for characters of different
2598 contained
= ns
->contained
;
2599 for (; contained
; contained
= contained
->sibling
)
2600 if (contained
->proc_name
2601 && strcmp (name
, contained
->proc_name
->name
) == 0)
2603 copy
= contained
->proc_name
;
2607 /* Set up namespace. */
2608 sub_ns
= gfc_get_namespace (ns
, 0);
2609 sub_ns
->sibling
= ns
->contained
;
2610 ns
->contained
= sub_ns
;
2611 sub_ns
->resolved
= 1;
2612 /* Set up procedure symbol. */
2613 if (ts
->type
!= BT_CHARACTER
)
2614 sprintf (name
, "__copy_%s", tname
);
2616 /* __copy is always the same for characters. */
2617 sprintf (name
, "__copy_character_%d", ts
->kind
);
2618 gfc_get_symbol (name
, sub_ns
, ©
);
2619 sub_ns
->proc_name
= copy
;
2620 copy
->attr
.flavor
= FL_PROCEDURE
;
2621 copy
->attr
.subroutine
= 1;
2622 copy
->attr
.pure
= 1;
2623 copy
->attr
.if_source
= IFSRC_DECL
;
2624 /* This is elemental so that arrays are automatically
2625 treated correctly by the scalarizer. */
2626 copy
->attr
.elemental
= 1;
2627 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2628 copy
->module
= ns
->proc_name
->name
;
2629 gfc_set_sym_referenced (copy
);
2630 /* Set up formal arguments. */
2631 gfc_get_symbol ("src", sub_ns
, &src
);
2632 src
->ts
.type
= ts
->type
;
2633 src
->ts
.kind
= ts
->kind
;
2634 src
->attr
.flavor
= FL_VARIABLE
;
2635 src
->attr
.dummy
= 1;
2636 src
->attr
.intent
= INTENT_IN
;
2637 gfc_set_sym_referenced (src
);
2638 copy
->formal
= gfc_get_formal_arglist ();
2639 copy
->formal
->sym
= src
;
2640 gfc_get_symbol ("dst", sub_ns
, &dst
);
2641 dst
->ts
.type
= ts
->type
;
2642 dst
->ts
.kind
= ts
->kind
;
2643 dst
->attr
.flavor
= FL_VARIABLE
;
2644 dst
->attr
.dummy
= 1;
2645 dst
->attr
.intent
= INTENT_OUT
;
2646 gfc_set_sym_referenced (dst
);
2647 copy
->formal
->next
= gfc_get_formal_arglist ();
2648 copy
->formal
->next
->sym
= dst
;
2650 sub_ns
->code
= gfc_get_code ();
2651 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2652 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2653 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2655 /* Set initializer. */
2656 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2657 c
->ts
.interface
= copy
;
2659 /* Add component _final. */
2660 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2662 c
->attr
.proc_pointer
= 1;
2663 c
->attr
.access
= ACCESS_PRIVATE
;
2664 c
->tb
= XCNEW (gfc_typebound_proc
);
2666 c
->initializer
= gfc_get_null_expr (NULL
);
2668 vtab
->ts
.u
.derived
= vtype
;
2669 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2676 /* It is unexpected to have some symbols added at resolution or code
2677 generation time. We commit the changes in order to keep a clean state. */
2680 gfc_commit_symbol (vtab
);
2682 gfc_commit_symbol (vtype
);
2684 gfc_commit_symbol (def_init
);
2686 gfc_commit_symbol (copy
);
2688 gfc_commit_symbol (src
);
2690 gfc_commit_symbol (dst
);
2693 gfc_undo_symbols ();
2699 /* General worker function to find either a type-bound procedure or a
2700 type-bound user operator. */
2703 find_typebound_proc_uop (gfc_symbol
* derived
, gfc_try
* t
,
2704 const char* name
, bool noaccess
, bool uop
,
2710 /* Set correct symbol-root. */
2711 gcc_assert (derived
->f2k_derived
);
2712 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2713 : derived
->f2k_derived
->tb_sym_root
);
2715 /* Set default to failure. */
2719 /* Try to find it in the current type's namespace. */
2720 res
= gfc_find_symtree (root
, name
);
2721 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2727 if (!noaccess
&& derived
->attr
.use_assoc
2728 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2731 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2732 name
, derived
->name
, where
);
2740 /* Otherwise, recurse on parent type if derived is an extension. */
2741 if (derived
->attr
.extension
)
2743 gfc_symbol
* super_type
;
2744 super_type
= gfc_get_derived_super_type (derived
);
2745 gcc_assert (super_type
);
2747 return find_typebound_proc_uop (super_type
, t
, name
,
2748 noaccess
, uop
, where
);
2751 /* Nothing found. */
2756 /* Find a type-bound procedure or user operator by name for a derived-type
2757 (looking recursively through the super-types). */
2760 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
2761 const char* name
, bool noaccess
, locus
* where
)
2763 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2767 gfc_find_typebound_user_op (gfc_symbol
* derived
, gfc_try
* t
,
2768 const char* name
, bool noaccess
, locus
* where
)
2770 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2774 /* Find a type-bound intrinsic operator looking recursively through the
2775 super-type hierarchy. */
2778 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_try
* t
,
2779 gfc_intrinsic_op op
, bool noaccess
,
2782 gfc_typebound_proc
* res
;
2784 /* Set default to failure. */
2788 /* Try to find it in the current type's namespace. */
2789 if (derived
->f2k_derived
)
2790 res
= derived
->f2k_derived
->tb_op
[op
];
2795 if (res
&& !res
->error
)
2801 if (!noaccess
&& derived
->attr
.use_assoc
2802 && res
->access
== ACCESS_PRIVATE
)
2805 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2806 gfc_op2string (op
), derived
->name
, where
);
2814 /* Otherwise, recurse on parent type if derived is an extension. */
2815 if (derived
->attr
.extension
)
2817 gfc_symbol
* super_type
;
2818 super_type
= gfc_get_derived_super_type (derived
);
2819 gcc_assert (super_type
);
2821 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2825 /* Nothing found. */
2830 /* Get a typebound-procedure symtree or create and insert it if not yet
2831 present. This is like a very simplified version of gfc_get_sym_tree for
2832 tbp-symtrees rather than regular ones. */
2835 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2837 gfc_symtree
*result
;
2839 result
= gfc_find_symtree (*root
, name
);
2842 result
= gfc_new_symtree (root
, name
);
2843 gcc_assert (result
);
2844 result
->n
.tb
= NULL
;