1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2014 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"
56 #include "target-memory.h"
58 /* Inserts a derived type component reference in a data reference chain.
59 TS: base type of the ref chain so far, in which we will pick the component
60 REF: the address of the GFC_REF pointer to update
61 NAME: name of the component to insert
62 Note that component insertion makes sense only if we are at the end of
63 the chain (*REF == NULL) or if we are adding a missing "_data" component
64 to access the actual contents of a class object. */
67 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
72 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
73 type_sym
= ts
->u
.derived
;
75 new_ref
= gfc_get_ref ();
76 new_ref
->type
= REF_COMPONENT
;
78 new_ref
->u
.c
.sym
= type_sym
;
79 new_ref
->u
.c
.component
= gfc_find_component (type_sym
, name
, true, true);
80 gcc_assert (new_ref
->u
.c
.component
);
86 /* We need to update the base type in the trailing reference chain to
87 that of the new component. */
89 gcc_assert (strcmp (name
, "_data") == 0);
91 if (new_ref
->next
->type
== REF_COMPONENT
)
93 else if (new_ref
->next
->type
== REF_ARRAY
94 && new_ref
->next
->next
95 && new_ref
->next
->next
->type
== REF_COMPONENT
)
96 next
= new_ref
->next
->next
;
100 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
101 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
102 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
110 /* Tells whether we need to add a "_data" reference to access REF subobject
111 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
112 object accessed by REF is a variable; in other words it is a full object,
116 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
118 /* Only class containers may need the "_data" reference. */
119 if (ts
->type
!= BT_CLASS
)
122 /* Accessing a class container with an array reference is certainly wrong. */
123 if (ref
->type
!= REF_COMPONENT
)
126 /* Accessing the class container's fields is fine. */
127 if (ref
->u
.c
.component
->name
[0] == '_')
130 /* At this point we have a class container with a non class container's field
131 component reference. We don't want to add the "_data" component if we are
132 at the first reference and the symbol's type is an extended derived type.
133 In that case, conv_parent_component_references will do the right thing so
134 it is not absolutely necessary. Omitting it prevents a regression (see
135 class_41.f03) in the interface mapping mechanism. When evaluating string
136 lengths depending on dummy arguments, we create a fake symbol with a type
137 equal to that of the dummy type. However, because of type extension,
138 the backend type (corresponding to the actual argument) can have a
139 different (extended) type. Adding the "_data" component explicitly, using
140 the base type, confuses the gfc_conv_component_ref code which deals with
141 the extended type. */
142 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
145 /* We have a class container with a non class container's field component
146 reference that doesn't fall into the above. */
151 /* Browse through a data reference chain and add the missing "_data" references
152 when a subobject of a class object is accessed without it.
153 Note that it doesn't add the "_data" reference when the class container
154 is the last element in the reference chain. */
157 gfc_fix_class_refs (gfc_expr
*e
)
162 if ((e
->expr_type
!= EXPR_VARIABLE
163 && e
->expr_type
!= EXPR_FUNCTION
)
164 || (e
->expr_type
== EXPR_FUNCTION
165 && e
->value
.function
.isym
!= NULL
))
168 if (e
->expr_type
== EXPR_VARIABLE
)
169 ts
= &e
->symtree
->n
.sym
->ts
;
174 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
175 if (e
->value
.function
.esym
!= NULL
)
176 func
= e
->value
.function
.esym
;
178 func
= e
->symtree
->n
.sym
;
180 if (func
->result
!= NULL
)
181 ts
= &func
->result
->ts
;
186 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
188 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
189 insert_component_ref (ts
, ref
, "_data");
191 if ((*ref
)->type
== REF_COMPONENT
)
192 ts
= &(*ref
)->u
.c
.component
->ts
;
197 /* Insert a reference to the component of the given name.
198 Only to be used with CLASS containers and vtables. */
201 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
203 gfc_ref
**tail
= &(e
->ref
);
204 gfc_ref
*next
= NULL
;
205 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
206 while (*tail
!= NULL
)
208 if ((*tail
)->type
== REF_COMPONENT
)
210 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
212 && (*tail
)->next
->type
== REF_ARRAY
213 && (*tail
)->next
->next
== NULL
)
215 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
217 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
219 tail
= &((*tail
)->next
);
221 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
223 (*tail
) = gfc_get_ref();
224 (*tail
)->next
= next
;
225 (*tail
)->type
= REF_COMPONENT
;
226 (*tail
)->u
.c
.sym
= derived
;
227 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
228 gcc_assert((*tail
)->u
.c
.component
);
230 e
->ts
= (*tail
)->u
.c
.component
->ts
;
234 /* This is used to add both the _data component reference and an array
235 reference to class expressions. Used in translation of intrinsic
236 array inquiry functions. */
239 gfc_add_class_array_ref (gfc_expr
*e
)
241 int rank
= CLASS_DATA (e
)->as
->rank
;
242 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
244 gfc_add_component_ref (e
, "_data");
246 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
249 if (ref
->type
!= REF_ARRAY
)
251 ref
->next
= gfc_get_ref ();
253 ref
->type
= REF_ARRAY
;
254 ref
->u
.ar
.type
= AR_FULL
;
260 /* Unfortunately, class array expressions can appear in various conditions;
261 with and without both _data component and an arrayspec. This function
262 deals with that variability. The previous reference to 'ref' is to a
266 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
268 bool no_data
= false;
269 bool with_data
= false;
271 /* An array reference with no _data component. */
272 if (ref
&& ref
->type
== REF_ARRAY
274 && ref
->u
.ar
.type
!= AR_ELEMENT
)
277 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
281 /* Cover cases where _data appears, with or without an array ref. */
282 if (ref
&& ref
->type
== REF_COMPONENT
283 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
291 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
293 && ref
->type
== REF_COMPONENT
294 && ref
->next
->type
== REF_ARRAY
295 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
299 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
303 return no_data
|| with_data
;
307 /* Returns true if the expression contains a reference to a class
308 array. Notice that class array elements return false. */
311 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
321 /* Is this a class array object? ie. Is the symbol of type class? */
323 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
324 && CLASS_DATA (e
->symtree
->n
.sym
)
325 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
326 && class_array_ref_detected (e
->ref
, full_array
))
329 /* Or is this a class array component reference? */
330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
332 if (ref
->type
== REF_COMPONENT
333 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
334 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
335 && class_array_ref_detected (ref
->next
, full_array
))
343 /* Returns true if the expression is a reference to a class
344 scalar. This function is necessary because such expressions
345 can be dressed with a reference to the _data component and so
346 have a type other than BT_CLASS. */
349 gfc_is_class_scalar_expr (gfc_expr
*e
)
356 /* Is this a class object? */
358 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
359 && CLASS_DATA (e
->symtree
->n
.sym
)
360 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
362 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
363 && e
->ref
->next
== NULL
)))
366 /* Or is the final reference BT_CLASS or _data? */
367 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
369 if (ref
->type
== REF_COMPONENT
370 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
371 && CLASS_DATA (ref
->u
.c
.component
)
372 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
373 && (ref
->next
== NULL
374 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
375 && ref
->next
->next
== NULL
)))
383 /* Tells whether the expression E is a reference to a (scalar) class container.
384 Scalar because array class containers usually have an array reference after
385 them, and gfc_fix_class_refs will add the missing "_data" component reference
389 gfc_is_class_container_ref (gfc_expr
*e
)
394 if (e
->expr_type
!= EXPR_VARIABLE
)
395 return e
->ts
.type
== BT_CLASS
;
397 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
402 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
404 if (ref
->type
!= REF_COMPONENT
)
406 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
416 /* Build an initializer for CLASS pointers,
417 initializing the _data component to the init_expr (or NULL) and the _vptr
418 component to the corresponding type (or the declared type, given by ts). */
421 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
425 gfc_symbol
*vtab
= NULL
;
427 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
428 vtab
= gfc_find_vtab (&init_expr
->ts
);
430 vtab
= gfc_find_vtab (ts
);
432 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
433 &ts
->u
.derived
->declared_at
);
436 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
438 gfc_constructor
*ctor
= gfc_constructor_get();
439 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
440 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
441 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
442 ctor
->expr
= gfc_copy_expr (init_expr
);
444 ctor
->expr
= gfc_get_null_expr (NULL
);
445 gfc_constructor_append (&init
->value
.constructor
, ctor
);
452 /* Create a unique string identifier for a derived type, composed of its name
453 and module name. This is used to construct unique names for the class
454 containers and vtab symbols. */
457 get_unique_type_string (char *string
, gfc_symbol
*derived
)
459 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
460 if (derived
->attr
.unlimited_polymorphic
)
461 strcpy (dt_name
, "STAR");
463 strcpy (dt_name
, derived
->name
);
464 dt_name
[0] = TOUPPER (dt_name
[0]);
465 if (derived
->attr
.unlimited_polymorphic
)
466 sprintf (string
, "_%s", dt_name
);
467 else if (derived
->module
)
468 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
469 else if (derived
->ns
->proc_name
)
470 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
472 sprintf (string
, "_%s", dt_name
);
476 /* A relative of 'get_unique_type_string' which makes sure the generated
477 string will not be too long (replacing it by a hash string if needed). */
480 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
482 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
483 get_unique_type_string (&tmp
[0], derived
);
484 /* If string is too long, use hash value in hex representation (allow for
485 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
486 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
487 where %d is the (co)rank which can be up to n = 15. */
488 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
490 int h
= gfc_hash_value (derived
);
491 sprintf (string
, "%X", h
);
494 strcpy (string
, tmp
);
498 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
501 gfc_hash_value (gfc_symbol
*sym
)
503 unsigned int hash
= 0;
504 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
507 get_unique_type_string (&c
[0], sym
);
510 for (i
= 0; i
< len
; i
++)
511 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
513 /* Return the hash but take the modulus for the sake of module read,
514 even though this slightly increases the chance of collision. */
515 return (hash
% 100000000);
519 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
522 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
524 unsigned int hash
= 0;
525 const char *c
= gfc_typename (ts
);
530 for (i
= 0; i
< len
; i
++)
531 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
533 /* Return the hash but take the modulus for the sake of module read,
534 even though this slightly increases the chance of collision. */
535 return (hash
% 100000000);
539 /* Build a polymorphic CLASS entity, using the symbol that comes from
540 build_sym. A CLASS entity is represented by an encapsulating type,
541 which contains the declared type as '_data' component, plus a pointer
542 component '_vptr' which determines the dynamic type. */
545 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
546 gfc_array_spec
**as
, bool delayed_vtab
)
548 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
557 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
559 gfc_error ("Assumed size polymorphic objects or components, such "
560 "as that at %C, have not yet been implemented");
565 /* Class container has already been built. */
568 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
569 || attr
->select_type_temporary
|| attr
->associate_var
;
572 /* We can not build the class container yet. */
575 /* Determine the name of the encapsulating type. */
576 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
577 get_unique_hashed_string (tname
, ts
->u
.derived
);
578 if ((*as
) && attr
->allocatable
)
579 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
580 else if ((*as
) && attr
->pointer
)
581 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
583 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
584 else if (attr
->pointer
)
585 sprintf (name
, "__class_%s_p", tname
);
586 else if (attr
->allocatable
)
587 sprintf (name
, "__class_%s_a", tname
);
589 sprintf (name
, "__class_%s", tname
);
591 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
593 /* Find the top-level namespace. */
594 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
599 ns
= ts
->u
.derived
->ns
;
601 gfc_find_symbol (name
, ns
, 0, &fclass
);
605 /* If not there, create a new symbol. */
606 fclass
= gfc_new_symbol (name
, ns
);
607 st
= gfc_new_symtree (&ns
->sym_root
, name
);
609 gfc_set_sym_referenced (fclass
);
611 fclass
->ts
.type
= BT_UNKNOWN
;
612 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
613 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
614 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
615 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
619 /* Add component '_data'. */
620 if (!gfc_add_component (fclass
, "_data", &c
))
623 c
->ts
.type
= BT_DERIVED
;
624 c
->attr
.access
= ACCESS_PRIVATE
;
625 c
->ts
.u
.derived
= ts
->u
.derived
;
626 c
->attr
.class_pointer
= attr
->pointer
;
627 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
628 || attr
->select_type_temporary
;
629 c
->attr
.allocatable
= attr
->allocatable
;
630 c
->attr
.dimension
= attr
->dimension
;
631 c
->attr
.codimension
= attr
->codimension
;
632 c
->attr
.abstract
= fclass
->attr
.abstract
;
634 c
->initializer
= NULL
;
636 /* Add component '_vptr'. */
637 if (!gfc_add_component (fclass
, "_vptr", &c
))
639 c
->ts
.type
= BT_DERIVED
;
641 || (ts
->u
.derived
->f2k_derived
642 && ts
->u
.derived
->f2k_derived
->finalizers
))
643 c
->ts
.u
.derived
= NULL
;
646 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
648 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
650 c
->attr
.access
= ACCESS_PRIVATE
;
654 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
656 /* Since the extension field is 8 bit wide, we can only have
657 up to 255 extension levels. */
658 if (ts
->u
.derived
->attr
.extension
== 255)
660 gfc_error ("Maximum extension level reached with type '%s' at %L",
661 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
665 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
666 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
667 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
670 fclass
->attr
.is_class
= 1;
671 ts
->u
.derived
= fclass
;
672 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
678 /* Add a procedure pointer component to the vtype
679 to represent a specific type-bound procedure. */
682 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
686 if (tb
->non_overridable
)
689 c
= gfc_find_component (vtype
, name
, true, true);
693 /* Add procedure component. */
694 if (!gfc_add_component (vtype
, name
, &c
))
698 c
->tb
= XCNEW (gfc_typebound_proc
);
701 c
->attr
.procedure
= 1;
702 c
->attr
.proc_pointer
= 1;
703 c
->attr
.flavor
= FL_PROCEDURE
;
704 c
->attr
.access
= ACCESS_PRIVATE
;
705 c
->attr
.external
= 1;
707 c
->attr
.if_source
= IFSRC_IFBODY
;
709 else if (c
->attr
.proc_pointer
&& c
->tb
)
717 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
718 c
->ts
.interface
= ifc
;
720 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
721 c
->attr
.pure
= ifc
->attr
.pure
;
726 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
729 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
735 add_procs_to_declared_vtab1 (st
->left
, vtype
);
738 add_procs_to_declared_vtab1 (st
->right
, vtype
);
740 if (st
->n
.tb
&& !st
->n
.tb
->error
741 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
742 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
746 /* Copy procedure pointers components from the parent type. */
749 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
754 vtab
= gfc_find_derived_vtab (declared
);
756 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
758 if (gfc_find_component (vtype
, cmp
->name
, true, true))
761 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
766 /* Returns true if any of its nonpointer nonallocatable components or
767 their nonpointer nonallocatable subcomponents has a finalization
771 has_finalizer_component (gfc_symbol
*derived
)
775 for (c
= derived
->components
; c
; c
= c
->next
)
777 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
778 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
781 if (c
->ts
.type
== BT_DERIVED
782 && !c
->attr
.pointer
&& !c
->attr
.allocatable
783 && has_finalizer_component (c
->ts
.u
.derived
))
791 comp_is_finalizable (gfc_component
*comp
)
793 if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
795 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
796 && (comp
->ts
.u
.derived
->attr
.alloc_comp
797 || has_finalizer_component (comp
->ts
.u
.derived
)
798 || (comp
->ts
.u
.derived
->f2k_derived
799 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
801 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
802 && CLASS_DATA (comp
)->attr
.allocatable
)
809 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
810 neither allocatable nor a pointer but has a finalizer, call it. If it
811 is a nonpointer component with allocatable components or has finalizers, walk
812 them. Either of them is required; other nonallocatables and pointers aren't
814 Note: If the component is allocatable, the DEALLOCATE handling takes care
815 of calling the appropriate finalizers, coarray deregistering, and
816 deallocation of allocatable subcomponents. */
819 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
820 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
)
825 if (!comp_is_finalizable (comp
))
828 e
= gfc_copy_expr (expr
);
830 e
->ref
= ref
= gfc_get_ref ();
833 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
835 ref
->next
= gfc_get_ref ();
838 ref
->type
= REF_COMPONENT
;
839 ref
->u
.c
.sym
= derived
;
840 ref
->u
.c
.component
= comp
;
843 if (comp
->attr
.dimension
|| comp
->attr
.codimension
844 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
845 && (CLASS_DATA (comp
)->attr
.dimension
846 || CLASS_DATA (comp
)->attr
.codimension
)))
848 ref
->next
= gfc_get_ref ();
849 ref
->next
->type
= REF_ARRAY
;
850 ref
->next
->u
.ar
.dimen
= 0;
851 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
853 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
854 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
857 /* Call DEALLOCATE (comp, stat=ignore). */
858 if (comp
->attr
.allocatable
859 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
860 && CLASS_DATA (comp
)->attr
.allocatable
))
862 gfc_code
*dealloc
, *block
= NULL
;
864 /* Add IF (fini_coarray). */
865 if (comp
->attr
.codimension
866 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
867 && CLASS_DATA (comp
)->attr
.allocatable
))
869 block
= gfc_get_code (EXEC_IF
);
872 (*code
)->next
= block
;
873 (*code
) = (*code
)->next
;
878 block
->block
= gfc_get_code (EXEC_IF
);
879 block
= block
->block
;
880 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
883 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
885 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
886 dealloc
->ext
.alloc
.list
->expr
= e
;
887 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
890 block
->next
= dealloc
;
893 (*code
)->next
= dealloc
;
894 (*code
) = (*code
)->next
;
899 else if (comp
->ts
.type
== BT_DERIVED
900 && comp
->ts
.u
.derived
->f2k_derived
901 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
903 /* Call FINAL_WRAPPER (comp); */
904 gfc_code
*final_wrap
;
908 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
909 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
910 if (strcmp (c
->name
, "_final") == 0)
914 final_wrap
= gfc_get_code (EXEC_CALL
);
915 final_wrap
->symtree
= c
->initializer
->symtree
;
916 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
917 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
918 final_wrap
->ext
.actual
->expr
= e
;
922 (*code
)->next
= final_wrap
;
923 (*code
) = (*code
)->next
;
926 (*code
) = final_wrap
;
932 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
933 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
939 /* Generate code equivalent to
940 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
941 + offset, c_ptr), ptr). */
944 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
945 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
948 gfc_expr
*expr
, *expr2
;
951 block
= gfc_get_code (EXEC_CALL
);
952 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
953 block
->resolved_sym
= block
->symtree
->n
.sym
;
954 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
955 block
->resolved_sym
->attr
.intrinsic
= 1;
956 block
->resolved_sym
->attr
.subroutine
= 1;
957 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
958 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
959 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
960 gfc_commit_symbol (block
->resolved_sym
);
962 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
963 block
->ext
.actual
= gfc_get_actual_arglist ();
964 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
965 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
967 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
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
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
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
, 3, 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
= gfc_get_code (EXEC_ASSIGN
);
1032 block
= block
->next
;
1033 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1034 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1037 iter
= gfc_get_iterator ();
1038 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1039 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1040 iter
->end
= gfc_copy_expr (rank
);
1041 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1042 block
->next
= gfc_get_code (EXEC_DO
);
1043 block
= block
->next
;
1044 block
->ext
.iterator
= iter
;
1045 block
->block
= gfc_get_code (EXEC_DO
);
1047 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1050 /* mod (idx, sizes(idx2)). */
1051 expr
= gfc_lval_expr_from_sym (sizes
);
1052 expr
->ref
= gfc_get_ref ();
1053 expr
->ref
->type
= REF_ARRAY
;
1054 expr
->ref
->u
.ar
.as
= sizes
->as
;
1055 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1056 expr
->ref
->u
.ar
.dimen
= 1;
1057 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1058 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1060 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1061 gfc_current_locus
, 2,
1062 gfc_lval_expr_from_sym (idx
), expr
);
1065 /* (...) / sizes(idx2-1). */
1066 expr2
= gfc_get_expr ();
1067 expr2
->expr_type
= EXPR_OP
;
1068 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1069 expr2
->value
.op
.op1
= expr
;
1070 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1071 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1072 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1073 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1074 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1075 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1076 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1077 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1078 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1079 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1080 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1081 = gfc_lval_expr_from_sym (idx2
);
1082 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1083 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1084 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1085 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1086 expr2
->ts
= idx
->ts
;
1088 /* ... * strides(idx2). */
1089 expr
= gfc_get_expr ();
1090 expr
->expr_type
= EXPR_OP
;
1091 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1092 expr
->value
.op
.op1
= expr2
;
1093 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1094 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1095 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1096 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1097 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1098 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1099 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1100 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1103 /* offset = offset + ... */
1104 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1105 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1106 block
->block
->next
->expr2
= gfc_get_expr ();
1107 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1108 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1109 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1110 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1111 block
->block
->next
->expr2
->ts
= idx
->ts
;
1113 /* After the loop: offset = offset * byte_stride. */
1114 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1115 block
= block
->next
;
1116 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1117 block
->expr2
= gfc_get_expr ();
1118 block
->expr2
->expr_type
= EXPR_OP
;
1119 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1120 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1121 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1122 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1127 /* Insert code of the following form:
1130 integer(c_intptr_t) :: i
1132 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1133 && (is_contiguous || !final_rank3->attr.contiguous
1134 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1135 || 0 == STORAGE_SIZE (array)) then
1136 call final_rank3 (array)
1139 integer(c_intptr_t) :: offset, j
1140 type(t) :: tmp(shape (array))
1142 do i = 0, size (array)-1
1143 offset = obtain_offset(i, strides, sizes, byte_stride)
1144 addr = transfer (c_loc (array), addr) + offset
1145 call c_f_pointer (transfer (addr, cptr), ptr)
1147 addr = transfer (c_loc (tmp), addr)
1148 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1149 call c_f_pointer (transfer (addr, cptr), ptr2)
1152 call final_rank3 (tmp)
1158 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1159 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1160 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1162 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1163 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1164 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1165 gfc_namespace
*sub_ns
)
1167 gfc_symbol
*tmp_array
, *ptr2
;
1168 gfc_expr
*size_expr
, *offset2
, *expr
;
1174 block
->next
= gfc_get_code (EXEC_IF
);
1175 block
= block
->next
;
1177 block
->block
= gfc_get_code (EXEC_IF
);
1178 block
= block
->block
;
1180 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1181 size_expr
= gfc_get_expr ();
1182 size_expr
->where
= gfc_current_locus
;
1183 size_expr
->expr_type
= EXPR_OP
;
1184 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1186 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1187 size_expr
->value
.op
.op1
1188 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1189 "storage_size", gfc_current_locus
, 2,
1190 gfc_lval_expr_from_sym (array
),
1191 gfc_get_int_expr (gfc_index_integer_kind
,
1194 /* NUMERIC_STORAGE_SIZE. */
1195 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1196 gfc_character_storage_size
);
1197 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1198 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1200 /* IF condition: (stride == size_expr
1201 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1203 || 0 == size_expr. */
1204 block
->expr1
= gfc_get_expr ();
1205 block
->expr1
->ts
.type
= BT_LOGICAL
;
1206 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1207 block
->expr1
->expr_type
= EXPR_OP
;
1208 block
->expr1
->where
= gfc_current_locus
;
1210 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1212 /* byte_stride == size_expr */
1213 expr
= gfc_get_expr ();
1214 expr
->ts
.type
= BT_LOGICAL
;
1215 expr
->ts
.kind
= gfc_default_logical_kind
;
1216 expr
->expr_type
= EXPR_OP
;
1217 expr
->where
= gfc_current_locus
;
1218 expr
->value
.op
.op
= INTRINSIC_EQ
;
1220 = gfc_lval_expr_from_sym (byte_stride
);
1221 expr
->value
.op
.op2
= size_expr
;
1223 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1224 add is_contiguous check. */
1226 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1227 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1230 expr2
= gfc_get_expr ();
1231 expr2
->ts
.type
= BT_LOGICAL
;
1232 expr2
->ts
.kind
= gfc_default_logical_kind
;
1233 expr2
->expr_type
= EXPR_OP
;
1234 expr2
->where
= gfc_current_locus
;
1235 expr2
->value
.op
.op
= INTRINSIC_AND
;
1236 expr2
->value
.op
.op1
= expr
;
1237 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1241 block
->expr1
->value
.op
.op1
= expr
;
1243 /* 0 == size_expr */
1244 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1245 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1246 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1247 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1248 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1249 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1250 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1251 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1252 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1254 /* IF body: call final subroutine. */
1255 block
->next
= gfc_get_code (EXEC_CALL
);
1256 block
->next
->symtree
= fini
->proc_tree
;
1257 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1258 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1259 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1263 block
->block
= gfc_get_code (EXEC_IF
);
1264 block
= block
->block
;
1266 /* BLOCK ... END BLOCK. */
1267 block
->next
= gfc_get_code (EXEC_BLOCK
);
1268 block
= block
->next
;
1270 ns
= gfc_build_block_ns (sub_ns
);
1271 block
->ext
.block
.ns
= ns
;
1272 block
->ext
.block
.assoc
= NULL
;
1274 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1275 ptr2
->ts
.type
= BT_DERIVED
;
1276 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1277 ptr2
->attr
.flavor
= FL_VARIABLE
;
1278 ptr2
->attr
.pointer
= 1;
1279 ptr2
->attr
.artificial
= 1;
1280 gfc_set_sym_referenced (ptr2
);
1281 gfc_commit_symbol (ptr2
);
1283 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1284 tmp_array
->ts
.type
= BT_DERIVED
;
1285 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1286 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1287 tmp_array
->attr
.dimension
= 1;
1288 tmp_array
->attr
.artificial
= 1;
1289 tmp_array
->as
= gfc_get_array_spec();
1290 tmp_array
->attr
.intent
= INTENT_INOUT
;
1291 tmp_array
->as
->type
= AS_EXPLICIT
;
1292 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1294 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1296 gfc_expr
*shape_expr
;
1297 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1299 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1301 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1302 gfc_current_locus
, 3,
1303 gfc_lval_expr_from_sym (array
),
1304 gfc_get_int_expr (gfc_default_integer_kind
,
1306 gfc_get_int_expr (gfc_default_integer_kind
,
1308 gfc_index_integer_kind
));
1309 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1310 tmp_array
->as
->upper
[i
] = shape_expr
;
1312 gfc_set_sym_referenced (tmp_array
);
1313 gfc_commit_symbol (tmp_array
);
1316 iter
= gfc_get_iterator ();
1317 iter
->var
= gfc_lval_expr_from_sym (idx
);
1318 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1319 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1320 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1322 block
= gfc_get_code (EXEC_DO
);
1324 block
->ext
.iterator
= iter
;
1325 block
->block
= gfc_get_code (EXEC_DO
);
1327 /* Offset calculation for the new array: idx * size of type (in bytes). */
1328 offset2
= gfc_get_expr ();
1329 offset2
->expr_type
= EXPR_OP
;
1330 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1331 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1332 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1333 offset2
->ts
= byte_stride
->ts
;
1335 /* Offset calculation of "array". */
1336 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1337 byte_stride
, rank
, block
->block
, sub_ns
);
1340 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1341 + idx * stride, c_ptr), ptr). */
1342 block2
->next
= finalization_scalarizer (array
, ptr
,
1343 gfc_lval_expr_from_sym (offset
),
1345 block2
= block2
->next
;
1346 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1347 block2
= block2
->next
;
1350 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1351 block2
= block2
->next
;
1352 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1353 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1355 /* Call now the user's final subroutine. */
1356 block
->next
= gfc_get_code (EXEC_CALL
);
1357 block
= block
->next
;
1358 block
->symtree
= fini
->proc_tree
;
1359 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1360 block
->ext
.actual
= gfc_get_actual_arglist ();
1361 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1363 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1369 iter
= gfc_get_iterator ();
1370 iter
->var
= gfc_lval_expr_from_sym (idx
);
1371 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1372 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1373 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1375 block
->next
= gfc_get_code (EXEC_DO
);
1376 block
= block
->next
;
1377 block
->ext
.iterator
= iter
;
1378 block
->block
= gfc_get_code (EXEC_DO
);
1380 /* Offset calculation of "array". */
1381 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1382 byte_stride
, rank
, block
->block
, sub_ns
);
1385 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1386 + offset, c_ptr), ptr). */
1387 block2
->next
= finalization_scalarizer (array
, ptr
,
1388 gfc_lval_expr_from_sym (offset
),
1390 block2
= block2
->next
;
1391 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1392 gfc_copy_expr (offset2
), sub_ns
);
1393 block2
= block2
->next
;
1396 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1397 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1398 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1402 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1403 derived type "derived". The function first calls the approriate FINAL
1404 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1405 components (but not the inherited ones). Last, it calls the wrapper
1406 subroutine of the parent. The generated wrapper procedure takes as argument
1407 an assumed-rank array.
1408 If neither allocatable components nor FINAL subroutines exists, the vtab
1409 will contain a NULL pointer.
1410 The generated function has the form
1411 _final(assumed-rank array, stride, skip_corarray)
1412 where the array has to be contiguous (except of the lowest dimension). The
1413 stride (in bytes) is used to allow different sizes for ancestor types by
1414 skipping over the additionally added components in the scalarizer. If
1415 "fini_coarray" is false, coarray components are not finalized to allow for
1416 the correct semantic with intrinsic assignment. */
1419 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1420 const char *tname
, gfc_component
*vtab_final
)
1422 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1423 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1424 gfc_component
*comp
;
1425 gfc_namespace
*sub_ns
;
1426 gfc_code
*last_code
, *block
;
1427 char name
[GFC_MAX_SYMBOL_LEN
+1];
1428 bool finalizable_comp
= false;
1429 bool expr_null_wrapper
= false;
1430 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1433 if (derived
->attr
.unlimited_polymorphic
)
1435 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1439 /* Search for the ancestor's finalizers. */
1440 if (derived
->attr
.extension
&& derived
->components
1441 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1442 || has_finalizer_component (derived
)))
1445 gfc_component
*comp
;
1447 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1448 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1449 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1451 ancestor_wrapper
= comp
->initializer
;
1456 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1457 components: Return a NULL() expression; we defer this a bit to have have
1458 an interface declaration. */
1459 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1460 && !derived
->attr
.alloc_comp
1461 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1462 && !has_finalizer_component (derived
))
1463 expr_null_wrapper
= true;
1465 /* Check whether there are new allocatable components. */
1466 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1468 if (comp
== derived
->components
&& derived
->attr
.extension
1469 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1472 finalizable_comp
|= comp_is_finalizable (comp
);
1475 /* If there is no new finalizer and no new allocatable, return with
1476 an expr to the ancestor's one. */
1477 if (!expr_null_wrapper
&& !finalizable_comp
1478 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1480 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1481 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1482 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1483 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1487 /* We now create a wrapper, which does the following:
1488 1. Call the suitable finalization subroutine for this type
1489 2. Loop over all noninherited allocatable components and noninherited
1490 components with allocatable components and DEALLOCATE those; this will
1491 take care of finalizers, coarray deregistering and allocatable
1493 3. Call the ancestor's finalizer. */
1495 /* Declare the wrapper function; it takes an assumed-rank array
1496 and a VALUE logical as arguments. */
1498 /* Set up the namespace. */
1499 sub_ns
= gfc_get_namespace (ns
, 0);
1500 sub_ns
->sibling
= ns
->contained
;
1501 if (!expr_null_wrapper
)
1502 ns
->contained
= sub_ns
;
1503 sub_ns
->resolved
= 1;
1505 /* Set up the procedure symbol. */
1506 sprintf (name
, "__final_%s", tname
);
1507 gfc_get_symbol (name
, sub_ns
, &final
);
1508 sub_ns
->proc_name
= final
;
1509 final
->attr
.flavor
= FL_PROCEDURE
;
1510 final
->attr
.function
= 1;
1511 final
->attr
.pure
= 0;
1512 final
->result
= final
;
1513 final
->ts
.type
= BT_INTEGER
;
1515 final
->attr
.artificial
= 1;
1516 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1517 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1518 final
->module
= ns
->proc_name
->name
;
1519 gfc_set_sym_referenced (final
);
1520 gfc_commit_symbol (final
);
1522 /* Set up formal argument. */
1523 gfc_get_symbol ("array", sub_ns
, &array
);
1524 array
->ts
.type
= BT_DERIVED
;
1525 array
->ts
.u
.derived
= derived
;
1526 array
->attr
.flavor
= FL_VARIABLE
;
1527 array
->attr
.dummy
= 1;
1528 array
->attr
.contiguous
= 1;
1529 array
->attr
.dimension
= 1;
1530 array
->attr
.artificial
= 1;
1531 array
->as
= gfc_get_array_spec();
1532 array
->as
->type
= AS_ASSUMED_RANK
;
1533 array
->as
->rank
= -1;
1534 array
->attr
.intent
= INTENT_INOUT
;
1535 gfc_set_sym_referenced (array
);
1536 final
->formal
= gfc_get_formal_arglist ();
1537 final
->formal
->sym
= array
;
1538 gfc_commit_symbol (array
);
1540 /* Set up formal argument. */
1541 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1542 byte_stride
->ts
.type
= BT_INTEGER
;
1543 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1544 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1545 byte_stride
->attr
.dummy
= 1;
1546 byte_stride
->attr
.value
= 1;
1547 byte_stride
->attr
.artificial
= 1;
1548 gfc_set_sym_referenced (byte_stride
);
1549 final
->formal
->next
= gfc_get_formal_arglist ();
1550 final
->formal
->next
->sym
= byte_stride
;
1551 gfc_commit_symbol (byte_stride
);
1553 /* Set up formal argument. */
1554 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1555 fini_coarray
->ts
.type
= BT_LOGICAL
;
1556 fini_coarray
->ts
.kind
= 1;
1557 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1558 fini_coarray
->attr
.dummy
= 1;
1559 fini_coarray
->attr
.value
= 1;
1560 fini_coarray
->attr
.artificial
= 1;
1561 gfc_set_sym_referenced (fini_coarray
);
1562 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1563 final
->formal
->next
->next
->sym
= fini_coarray
;
1564 gfc_commit_symbol (fini_coarray
);
1566 /* Return with a NULL() expression but with an interface which has
1567 the formal arguments. */
1568 if (expr_null_wrapper
)
1570 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1571 vtab_final
->ts
.interface
= final
;
1575 /* Local variables. */
1577 gfc_get_symbol ("idx", sub_ns
, &idx
);
1578 idx
->ts
.type
= BT_INTEGER
;
1579 idx
->ts
.kind
= gfc_index_integer_kind
;
1580 idx
->attr
.flavor
= FL_VARIABLE
;
1581 idx
->attr
.artificial
= 1;
1582 gfc_set_sym_referenced (idx
);
1583 gfc_commit_symbol (idx
);
1585 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1586 idx2
->ts
.type
= BT_INTEGER
;
1587 idx2
->ts
.kind
= gfc_index_integer_kind
;
1588 idx2
->attr
.flavor
= FL_VARIABLE
;
1589 idx2
->attr
.artificial
= 1;
1590 gfc_set_sym_referenced (idx2
);
1591 gfc_commit_symbol (idx2
);
1593 gfc_get_symbol ("offset", sub_ns
, &offset
);
1594 offset
->ts
.type
= BT_INTEGER
;
1595 offset
->ts
.kind
= gfc_index_integer_kind
;
1596 offset
->attr
.flavor
= FL_VARIABLE
;
1597 offset
->attr
.artificial
= 1;
1598 gfc_set_sym_referenced (offset
);
1599 gfc_commit_symbol (offset
);
1601 /* Create RANK expression. */
1602 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1603 gfc_current_locus
, 1,
1604 gfc_lval_expr_from_sym (array
));
1605 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1606 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1608 /* Create is_contiguous variable. */
1609 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1610 is_contiguous
->ts
.type
= BT_LOGICAL
;
1611 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1612 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1613 is_contiguous
->attr
.artificial
= 1;
1614 gfc_set_sym_referenced (is_contiguous
);
1615 gfc_commit_symbol (is_contiguous
);
1617 /* Create "sizes(0..rank)" variable, which contains the multiplied
1618 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1619 sizes(2) = sizes(1) * extent(dim=2) etc. */
1620 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1621 sizes
->ts
.type
= BT_INTEGER
;
1622 sizes
->ts
.kind
= gfc_index_integer_kind
;
1623 sizes
->attr
.flavor
= FL_VARIABLE
;
1624 sizes
->attr
.dimension
= 1;
1625 sizes
->attr
.artificial
= 1;
1626 sizes
->as
= gfc_get_array_spec();
1627 sizes
->attr
.intent
= INTENT_INOUT
;
1628 sizes
->as
->type
= AS_EXPLICIT
;
1629 sizes
->as
->rank
= 1;
1630 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1631 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1632 gfc_set_sym_referenced (sizes
);
1633 gfc_commit_symbol (sizes
);
1635 /* Create "strides(1..rank)" variable, which contains the strides per
1637 gfc_get_symbol ("strides", sub_ns
, &strides
);
1638 strides
->ts
.type
= BT_INTEGER
;
1639 strides
->ts
.kind
= gfc_index_integer_kind
;
1640 strides
->attr
.flavor
= FL_VARIABLE
;
1641 strides
->attr
.dimension
= 1;
1642 strides
->attr
.artificial
= 1;
1643 strides
->as
= gfc_get_array_spec();
1644 strides
->attr
.intent
= INTENT_INOUT
;
1645 strides
->as
->type
= AS_EXPLICIT
;
1646 strides
->as
->rank
= 1;
1647 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1648 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1649 gfc_set_sym_referenced (strides
);
1650 gfc_commit_symbol (strides
);
1653 /* Set return value to 0. */
1654 last_code
= gfc_get_code (EXEC_ASSIGN
);
1655 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1656 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1657 sub_ns
->code
= last_code
;
1659 /* Set: is_contiguous = .true. */
1660 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1661 last_code
= last_code
->next
;
1662 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1663 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1664 &gfc_current_locus
, true);
1666 /* Set: sizes(0) = 1. */
1667 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1668 last_code
= last_code
->next
;
1669 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1670 last_code
->expr1
->ref
= gfc_get_ref ();
1671 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1672 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1673 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1674 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1675 last_code
->expr1
->ref
->u
.ar
.start
[0]
1676 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1677 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1678 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1682 strides(idx) = _F._stride (array, dim=idx)
1683 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1684 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1688 iter
= gfc_get_iterator ();
1689 iter
->var
= gfc_lval_expr_from_sym (idx
);
1690 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1691 iter
->end
= gfc_copy_expr (rank
);
1692 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1693 last_code
->next
= gfc_get_code (EXEC_DO
);
1694 last_code
= last_code
->next
;
1695 last_code
->ext
.iterator
= iter
;
1696 last_code
->block
= gfc_get_code (EXEC_DO
);
1698 /* strides(idx) = _F._stride(array,dim=idx). */
1699 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1700 block
= last_code
->block
->next
;
1702 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1703 block
->expr1
->ref
= gfc_get_ref ();
1704 block
->expr1
->ref
->type
= REF_ARRAY
;
1705 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1706 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1707 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1708 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1709 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1711 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1712 gfc_current_locus
, 2,
1713 gfc_lval_expr_from_sym (array
),
1714 gfc_lval_expr_from_sym (idx
));
1716 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1717 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1718 block
= block
->next
;
1720 /* sizes(idx) = ... */
1721 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1722 block
->expr1
->ref
= gfc_get_ref ();
1723 block
->expr1
->ref
->type
= REF_ARRAY
;
1724 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1725 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1726 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1727 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1728 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1730 block
->expr2
= gfc_get_expr ();
1731 block
->expr2
->expr_type
= EXPR_OP
;
1732 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1735 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1736 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1737 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1738 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1739 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1740 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1741 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1742 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1743 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1744 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1745 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1746 = gfc_lval_expr_from_sym (idx
);
1747 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1748 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1749 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1750 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1752 /* size(array, dim=idx, kind=index_kind). */
1753 block
->expr2
->value
.op
.op2
1754 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1755 gfc_current_locus
, 3,
1756 gfc_lval_expr_from_sym (array
),
1757 gfc_lval_expr_from_sym (idx
),
1758 gfc_get_int_expr (gfc_index_integer_kind
,
1760 gfc_index_integer_kind
));
1761 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1762 block
->expr2
->ts
= idx
->ts
;
1764 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1765 block
->next
= gfc_get_code (EXEC_IF
);
1766 block
= block
->next
;
1768 block
->block
= gfc_get_code (EXEC_IF
);
1769 block
= block
->block
;
1771 /* if condition: strides(idx) /= sizes(idx-1). */
1772 block
->expr1
= gfc_get_expr ();
1773 block
->expr1
->ts
.type
= BT_LOGICAL
;
1774 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1775 block
->expr1
->expr_type
= EXPR_OP
;
1776 block
->expr1
->where
= gfc_current_locus
;
1777 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1779 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1780 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1781 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1782 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1783 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1784 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1785 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1786 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1788 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1789 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1790 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1791 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1792 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1793 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1794 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1795 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1796 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1797 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1798 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1799 = gfc_lval_expr_from_sym (idx
);
1800 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1801 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1802 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1803 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1805 /* if body: is_contiguous = .false. */
1806 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1807 block
= block
->next
;
1808 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1809 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1810 &gfc_current_locus
, false);
1812 /* Obtain the size (number of elements) of "array" MINUS ONE,
1813 which is used in the scalarization. */
1814 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1815 nelem
->ts
.type
= BT_INTEGER
;
1816 nelem
->ts
.kind
= gfc_index_integer_kind
;
1817 nelem
->attr
.flavor
= FL_VARIABLE
;
1818 nelem
->attr
.artificial
= 1;
1819 gfc_set_sym_referenced (nelem
);
1820 gfc_commit_symbol (nelem
);
1822 /* nelem = sizes (rank) - 1. */
1823 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1824 last_code
= last_code
->next
;
1826 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1828 last_code
->expr2
= gfc_get_expr ();
1829 last_code
->expr2
->expr_type
= EXPR_OP
;
1830 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1831 last_code
->expr2
->value
.op
.op2
1832 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1833 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1835 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1836 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1837 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1838 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1839 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1840 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1841 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1842 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1844 /* Call final subroutines. We now generate code like:
1846 integer, pointer :: ptr
1848 integer(c_intptr_t) :: i, addr
1850 select case (rank (array))
1852 ! If needed, the array is packed
1853 call final_rank3 (array)
1855 do i = 0, size (array)-1
1856 addr = transfer (c_loc (array), addr) + i * stride
1857 call c_f_pointer (transfer (addr, cptr), ptr)
1858 call elemental_final (ptr)
1862 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1864 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1866 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1867 ptr
->ts
.type
= BT_DERIVED
;
1868 ptr
->ts
.u
.derived
= derived
;
1869 ptr
->attr
.flavor
= FL_VARIABLE
;
1870 ptr
->attr
.pointer
= 1;
1871 ptr
->attr
.artificial
= 1;
1872 gfc_set_sym_referenced (ptr
);
1873 gfc_commit_symbol (ptr
);
1875 /* SELECT CASE (RANK (array)). */
1876 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1877 last_code
= last_code
->next
;
1878 last_code
->expr1
= gfc_copy_expr (rank
);
1881 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1883 if (!fini
->proc_tree
)
1884 fini
->proc_tree
= gfc_find_sym_in_symtree (fini
->proc_sym
);
1885 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1891 /* CASE (fini_rank). */
1894 block
->block
= gfc_get_code (EXEC_SELECT
);
1895 block
= block
->block
;
1899 block
= gfc_get_code (EXEC_SELECT
);
1900 last_code
->block
= block
;
1902 block
->ext
.block
.case_list
= gfc_get_case ();
1903 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1904 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1905 block
->ext
.block
.case_list
->low
1906 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1907 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1909 block
->ext
.block
.case_list
->low
1910 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1911 block
->ext
.block
.case_list
->high
1912 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
1914 /* CALL fini_rank (array) - possibly with packing. */
1915 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1916 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1917 idx
, ptr
, nelem
, strides
,
1918 sizes
, idx2
, offset
, is_contiguous
,
1922 block
->next
= gfc_get_code (EXEC_CALL
);
1923 block
->next
->symtree
= fini
->proc_tree
;
1924 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1925 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1926 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1930 /* Elemental call - scalarized. */
1936 block
->block
= gfc_get_code (EXEC_SELECT
);
1937 block
= block
->block
;
1941 block
= gfc_get_code (EXEC_SELECT
);
1942 last_code
->block
= block
;
1944 block
->ext
.block
.case_list
= gfc_get_case ();
1947 iter
= gfc_get_iterator ();
1948 iter
->var
= gfc_lval_expr_from_sym (idx
);
1949 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1950 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1951 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1952 block
->next
= gfc_get_code (EXEC_DO
);
1953 block
= block
->next
;
1954 block
->ext
.iterator
= iter
;
1955 block
->block
= gfc_get_code (EXEC_DO
);
1957 /* Offset calculation. */
1958 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1959 byte_stride
, rank
, block
->block
,
1963 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1964 + offset, c_ptr), ptr). */
1966 = finalization_scalarizer (array
, ptr
,
1967 gfc_lval_expr_from_sym (offset
),
1969 block
= block
->next
;
1971 /* CALL final_elemental (array). */
1972 block
->next
= gfc_get_code (EXEC_CALL
);
1973 block
= block
->next
;
1974 block
->symtree
= fini_elem
->proc_tree
;
1975 block
->resolved_sym
= fini_elem
->proc_sym
;
1976 block
->ext
.actual
= gfc_get_actual_arglist ();
1977 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
1981 /* Finalize and deallocate allocatable components. The same manual
1982 scalarization is used as above. */
1984 if (finalizable_comp
)
1987 gfc_code
*block
= NULL
;
1991 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1992 ptr
->ts
.type
= BT_DERIVED
;
1993 ptr
->ts
.u
.derived
= derived
;
1994 ptr
->attr
.flavor
= FL_VARIABLE
;
1995 ptr
->attr
.pointer
= 1;
1996 ptr
->attr
.artificial
= 1;
1997 gfc_set_sym_referenced (ptr
);
1998 gfc_commit_symbol (ptr
);
2001 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2002 stat
->attr
.flavor
= FL_VARIABLE
;
2003 stat
->attr
.artificial
= 1;
2004 stat
->ts
.type
= BT_INTEGER
;
2005 stat
->ts
.kind
= gfc_default_integer_kind
;
2006 gfc_set_sym_referenced (stat
);
2007 gfc_commit_symbol (stat
);
2010 iter
= gfc_get_iterator ();
2011 iter
->var
= gfc_lval_expr_from_sym (idx
);
2012 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2013 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2014 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2015 last_code
->next
= gfc_get_code (EXEC_DO
);
2016 last_code
= last_code
->next
;
2017 last_code
->ext
.iterator
= iter
;
2018 last_code
->block
= gfc_get_code (EXEC_DO
);
2020 /* Offset calculation. */
2021 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2022 byte_stride
, rank
, last_code
->block
,
2026 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2027 + idx * stride, c_ptr), ptr). */
2028 block
->next
= finalization_scalarizer (array
, ptr
,
2029 gfc_lval_expr_from_sym(offset
),
2031 block
= block
->next
;
2033 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2035 if (comp
== derived
->components
&& derived
->attr
.extension
2036 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2039 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2040 stat
, fini_coarray
, &block
);
2041 if (!last_code
->block
->next
)
2042 last_code
->block
->next
= block
;
2047 /* Call the finalizer of the ancestor. */
2048 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2050 last_code
->next
= gfc_get_code (EXEC_CALL
);
2051 last_code
= last_code
->next
;
2052 last_code
->symtree
= ancestor_wrapper
->symtree
;
2053 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2055 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2056 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2057 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2058 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2059 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2060 last_code
->ext
.actual
->next
->next
->expr
2061 = gfc_lval_expr_from_sym (fini_coarray
);
2064 gfc_free_expr (rank
);
2065 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2066 vtab_final
->ts
.interface
= final
;
2070 /* Add procedure pointers for all type-bound procedures to a vtab. */
2073 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2075 gfc_symbol
* super_type
;
2077 super_type
= gfc_get_derived_super_type (derived
);
2079 if (super_type
&& (super_type
!= derived
))
2081 /* Make sure that the PPCs appear in the same order as in the parent. */
2082 copy_vtab_proc_comps (super_type
, vtype
);
2083 /* Only needed to get the PPC initializers right. */
2084 add_procs_to_declared_vtab (super_type
, vtype
);
2087 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2088 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2090 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2091 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2095 /* Find or generate the symbol for a derived type's vtab. */
2098 gfc_find_derived_vtab (gfc_symbol
*derived
)
2101 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2102 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2104 /* Find the top-level namespace. */
2105 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2109 /* If the type is a class container, use the underlying derived type. */
2110 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2111 derived
= gfc_get_derived_super_type (derived
);
2115 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2117 get_unique_hashed_string (tname
, derived
);
2118 sprintf (name
, "__vtab_%s", tname
);
2120 /* Look for the vtab symbol in various namespaces. */
2121 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2123 gfc_find_symbol (name
, ns
, 0, &vtab
);
2125 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2129 gfc_get_symbol (name
, ns
, &vtab
);
2130 vtab
->ts
.type
= BT_DERIVED
;
2131 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2132 &gfc_current_locus
))
2134 vtab
->attr
.target
= 1;
2135 vtab
->attr
.save
= SAVE_IMPLICIT
;
2136 vtab
->attr
.vtab
= 1;
2137 vtab
->attr
.access
= ACCESS_PUBLIC
;
2138 gfc_set_sym_referenced (vtab
);
2139 sprintf (name
, "__vtype_%s", tname
);
2141 gfc_find_symbol (name
, ns
, 0, &vtype
);
2145 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2147 gfc_get_symbol (name
, ns
, &vtype
);
2148 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2149 &gfc_current_locus
))
2151 vtype
->attr
.access
= ACCESS_PUBLIC
;
2152 vtype
->attr
.vtype
= 1;
2153 gfc_set_sym_referenced (vtype
);
2155 /* Add component '_hash'. */
2156 if (!gfc_add_component (vtype
, "_hash", &c
))
2158 c
->ts
.type
= BT_INTEGER
;
2160 c
->attr
.access
= ACCESS_PRIVATE
;
2161 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2162 NULL
, derived
->hash_value
);
2164 /* Add component '_size'. */
2165 if (!gfc_add_component (vtype
, "_size", &c
))
2167 c
->ts
.type
= BT_INTEGER
;
2169 c
->attr
.access
= ACCESS_PRIVATE
;
2170 /* Remember the derived type in ts.u.derived,
2171 so that the correct initializer can be set later on
2172 (in gfc_conv_structure). */
2173 c
->ts
.u
.derived
= derived
;
2174 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2177 /* Add component _extends. */
2178 if (!gfc_add_component (vtype
, "_extends", &c
))
2180 c
->attr
.pointer
= 1;
2181 c
->attr
.access
= ACCESS_PRIVATE
;
2182 if (!derived
->attr
.unlimited_polymorphic
)
2183 parent
= gfc_get_derived_super_type (derived
);
2189 parent_vtab
= gfc_find_derived_vtab (parent
);
2190 c
->ts
.type
= BT_DERIVED
;
2191 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2192 c
->initializer
= gfc_get_expr ();
2193 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2194 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2195 0, &c
->initializer
->symtree
);
2199 c
->ts
.type
= BT_DERIVED
;
2200 c
->ts
.u
.derived
= vtype
;
2201 c
->initializer
= gfc_get_null_expr (NULL
);
2204 if (!derived
->attr
.unlimited_polymorphic
2205 && derived
->components
== NULL
2206 && !derived
->attr
.zero_comp
)
2208 /* At this point an error must have occurred.
2209 Prevent further errors on the vtype components. */
2214 /* Add component _def_init. */
2215 if (!gfc_add_component (vtype
, "_def_init", &c
))
2217 c
->attr
.pointer
= 1;
2218 c
->attr
.artificial
= 1;
2219 c
->attr
.access
= ACCESS_PRIVATE
;
2220 c
->ts
.type
= BT_DERIVED
;
2221 c
->ts
.u
.derived
= derived
;
2222 if (derived
->attr
.unlimited_polymorphic
2223 || derived
->attr
.abstract
)
2224 c
->initializer
= gfc_get_null_expr (NULL
);
2227 /* Construct default initialization variable. */
2228 sprintf (name
, "__def_init_%s", tname
);
2229 gfc_get_symbol (name
, ns
, &def_init
);
2230 def_init
->attr
.target
= 1;
2231 def_init
->attr
.artificial
= 1;
2232 def_init
->attr
.save
= SAVE_IMPLICIT
;
2233 def_init
->attr
.access
= ACCESS_PUBLIC
;
2234 def_init
->attr
.flavor
= FL_VARIABLE
;
2235 gfc_set_sym_referenced (def_init
);
2236 def_init
->ts
.type
= BT_DERIVED
;
2237 def_init
->ts
.u
.derived
= derived
;
2238 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2240 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2243 /* Add component _copy. */
2244 if (!gfc_add_component (vtype
, "_copy", &c
))
2246 c
->attr
.proc_pointer
= 1;
2247 c
->attr
.access
= ACCESS_PRIVATE
;
2248 c
->tb
= XCNEW (gfc_typebound_proc
);
2250 if (derived
->attr
.unlimited_polymorphic
2251 || derived
->attr
.abstract
)
2252 c
->initializer
= gfc_get_null_expr (NULL
);
2255 /* Set up namespace. */
2256 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2257 sub_ns
->sibling
= ns
->contained
;
2258 ns
->contained
= sub_ns
;
2259 sub_ns
->resolved
= 1;
2260 /* Set up procedure symbol. */
2261 sprintf (name
, "__copy_%s", tname
);
2262 gfc_get_symbol (name
, sub_ns
, ©
);
2263 sub_ns
->proc_name
= copy
;
2264 copy
->attr
.flavor
= FL_PROCEDURE
;
2265 copy
->attr
.subroutine
= 1;
2266 copy
->attr
.pure
= 1;
2267 copy
->attr
.artificial
= 1;
2268 copy
->attr
.if_source
= IFSRC_DECL
;
2269 /* This is elemental so that arrays are automatically
2270 treated correctly by the scalarizer. */
2271 copy
->attr
.elemental
= 1;
2272 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2273 copy
->module
= ns
->proc_name
->name
;
2274 gfc_set_sym_referenced (copy
);
2275 /* Set up formal arguments. */
2276 gfc_get_symbol ("src", sub_ns
, &src
);
2277 src
->ts
.type
= BT_DERIVED
;
2278 src
->ts
.u
.derived
= derived
;
2279 src
->attr
.flavor
= FL_VARIABLE
;
2280 src
->attr
.dummy
= 1;
2281 src
->attr
.artificial
= 1;
2282 src
->attr
.intent
= INTENT_IN
;
2283 gfc_set_sym_referenced (src
);
2284 copy
->formal
= gfc_get_formal_arglist ();
2285 copy
->formal
->sym
= src
;
2286 gfc_get_symbol ("dst", sub_ns
, &dst
);
2287 dst
->ts
.type
= BT_DERIVED
;
2288 dst
->ts
.u
.derived
= derived
;
2289 dst
->attr
.flavor
= FL_VARIABLE
;
2290 dst
->attr
.dummy
= 1;
2291 dst
->attr
.artificial
= 1;
2292 dst
->attr
.intent
= INTENT_INOUT
;
2293 gfc_set_sym_referenced (dst
);
2294 copy
->formal
->next
= gfc_get_formal_arglist ();
2295 copy
->formal
->next
->sym
= dst
;
2297 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2298 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2299 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2300 /* Set initializer. */
2301 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2302 c
->ts
.interface
= copy
;
2305 /* Add component _final, which contains a procedure pointer to
2306 a wrapper which handles both the freeing of allocatable
2307 components and the calls to finalization subroutines.
2308 Note: The actual wrapper function can only be generated
2309 at resolution time. */
2310 if (!gfc_add_component (vtype
, "_final", &c
))
2312 c
->attr
.proc_pointer
= 1;
2313 c
->attr
.access
= ACCESS_PRIVATE
;
2314 c
->tb
= XCNEW (gfc_typebound_proc
);
2316 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2318 /* Add procedure pointers for type-bound procedures. */
2319 if (!derived
->attr
.unlimited_polymorphic
)
2320 add_procs_to_declared_vtab (derived
, vtype
);
2324 vtab
->ts
.u
.derived
= vtype
;
2325 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2332 /* It is unexpected to have some symbols added at resolution or code
2333 generation time. We commit the changes in order to keep a clean state. */
2336 gfc_commit_symbol (vtab
);
2338 gfc_commit_symbol (vtype
);
2340 gfc_commit_symbol (def_init
);
2342 gfc_commit_symbol (copy
);
2344 gfc_commit_symbol (src
);
2346 gfc_commit_symbol (dst
);
2349 gfc_undo_symbols ();
2355 /* Check if a derived type is finalizable. That is the case if it
2356 (1) has a FINAL subroutine or
2357 (2) has a nonpointer nonallocatable component of finalizable type.
2358 If it is finalizable, return an expression containing the
2359 finalization wrapper. */
2362 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2367 /* (1) Check for FINAL subroutines. */
2368 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2371 /* (2) Check for components of finalizable type. */
2372 for (c
= derived
->components
; c
; c
= c
->next
)
2373 if (c
->ts
.type
== BT_DERIVED
2374 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2375 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2381 /* Make sure vtab is generated. */
2382 vtab
= gfc_find_derived_vtab (derived
);
2385 /* Return finalizer expression. */
2386 gfc_component
*final
;
2387 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2388 gcc_assert (strcmp (final
->name
, "_final") == 0);
2389 gcc_assert (final
->initializer
2390 && final
->initializer
->expr_type
!= EXPR_NULL
);
2391 *final_expr
= final
->initializer
;
2397 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2398 needed to support unlimited polymorphism. */
2401 find_intrinsic_vtab (gfc_typespec
*ts
)
2404 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2405 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2408 if (ts
->type
== BT_CHARACTER
)
2412 gfc_error ("TODO: Deferred character length variable at %C cannot "
2413 "yet be associated with unlimited polymorphic entities");
2416 else if (ts
->u
.cl
&& ts
->u
.cl
->length
2417 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2418 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2421 /* Find the top-level namespace. */
2422 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2428 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2430 if (ts
->type
== BT_CHARACTER
)
2431 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2434 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2436 sprintf (name
, "__vtab_%s", tname
);
2438 /* Look for the vtab symbol in various namespaces. */
2439 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2441 gfc_find_symbol (name
, ns
, 0, &vtab
);
2445 gfc_get_symbol (name
, ns
, &vtab
);
2446 vtab
->ts
.type
= BT_DERIVED
;
2447 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2448 &gfc_current_locus
))
2450 vtab
->attr
.target
= 1;
2451 vtab
->attr
.save
= SAVE_IMPLICIT
;
2452 vtab
->attr
.vtab
= 1;
2453 vtab
->attr
.access
= ACCESS_PUBLIC
;
2454 gfc_set_sym_referenced (vtab
);
2455 sprintf (name
, "__vtype_%s", tname
);
2457 gfc_find_symbol (name
, ns
, 0, &vtype
);
2462 gfc_namespace
*sub_ns
;
2463 gfc_namespace
*contained
;
2466 gfc_get_symbol (name
, ns
, &vtype
);
2467 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2468 &gfc_current_locus
))
2470 vtype
->attr
.access
= ACCESS_PUBLIC
;
2471 vtype
->attr
.vtype
= 1;
2472 gfc_set_sym_referenced (vtype
);
2474 /* Add component '_hash'. */
2475 if (!gfc_add_component (vtype
, "_hash", &c
))
2477 c
->ts
.type
= BT_INTEGER
;
2479 c
->attr
.access
= ACCESS_PRIVATE
;
2480 hash
= gfc_intrinsic_hash_value (ts
);
2481 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2484 /* Add component '_size'. */
2485 if (!gfc_add_component (vtype
, "_size", &c
))
2487 c
->ts
.type
= BT_INTEGER
;
2489 c
->attr
.access
= ACCESS_PRIVATE
;
2491 /* Build a minimal expression to make use of
2492 target-memory.c/gfc_element_size for 'size'. */
2493 e
= gfc_get_expr ();
2495 e
->expr_type
= EXPR_VARIABLE
;
2496 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2498 (int)gfc_element_size (e
));
2501 /* Add component _extends. */
2502 if (!gfc_add_component (vtype
, "_extends", &c
))
2504 c
->attr
.pointer
= 1;
2505 c
->attr
.access
= ACCESS_PRIVATE
;
2506 c
->ts
.type
= BT_VOID
;
2507 c
->initializer
= gfc_get_null_expr (NULL
);
2509 /* Add component _def_init. */
2510 if (!gfc_add_component (vtype
, "_def_init", &c
))
2512 c
->attr
.pointer
= 1;
2513 c
->attr
.access
= ACCESS_PRIVATE
;
2514 c
->ts
.type
= BT_VOID
;
2515 c
->initializer
= gfc_get_null_expr (NULL
);
2517 /* Add component _copy. */
2518 if (!gfc_add_component (vtype
, "_copy", &c
))
2520 c
->attr
.proc_pointer
= 1;
2521 c
->attr
.access
= ACCESS_PRIVATE
;
2522 c
->tb
= XCNEW (gfc_typebound_proc
);
2525 /* Check to see if copy function already exists. Note
2526 that this is only used for characters of different
2528 contained
= ns
->contained
;
2529 for (; contained
; contained
= contained
->sibling
)
2530 if (contained
->proc_name
2531 && strcmp (name
, contained
->proc_name
->name
) == 0)
2533 copy
= contained
->proc_name
;
2537 /* Set up namespace. */
2538 sub_ns
= gfc_get_namespace (ns
, 0);
2539 sub_ns
->sibling
= ns
->contained
;
2540 ns
->contained
= sub_ns
;
2541 sub_ns
->resolved
= 1;
2542 /* Set up procedure symbol. */
2543 if (ts
->type
!= BT_CHARACTER
)
2544 sprintf (name
, "__copy_%s", tname
);
2546 /* __copy is always the same for characters. */
2547 sprintf (name
, "__copy_character_%d", ts
->kind
);
2548 gfc_get_symbol (name
, sub_ns
, ©
);
2549 sub_ns
->proc_name
= copy
;
2550 copy
->attr
.flavor
= FL_PROCEDURE
;
2551 copy
->attr
.subroutine
= 1;
2552 copy
->attr
.pure
= 1;
2553 copy
->attr
.if_source
= IFSRC_DECL
;
2554 /* This is elemental so that arrays are automatically
2555 treated correctly by the scalarizer. */
2556 copy
->attr
.elemental
= 1;
2557 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2558 copy
->module
= ns
->proc_name
->name
;
2559 gfc_set_sym_referenced (copy
);
2560 /* Set up formal arguments. */
2561 gfc_get_symbol ("src", sub_ns
, &src
);
2562 src
->ts
.type
= ts
->type
;
2563 src
->ts
.kind
= ts
->kind
;
2564 src
->attr
.flavor
= FL_VARIABLE
;
2565 src
->attr
.dummy
= 1;
2566 src
->attr
.intent
= INTENT_IN
;
2567 gfc_set_sym_referenced (src
);
2568 copy
->formal
= gfc_get_formal_arglist ();
2569 copy
->formal
->sym
= src
;
2570 gfc_get_symbol ("dst", sub_ns
, &dst
);
2571 dst
->ts
.type
= ts
->type
;
2572 dst
->ts
.kind
= ts
->kind
;
2573 dst
->attr
.flavor
= FL_VARIABLE
;
2574 dst
->attr
.dummy
= 1;
2575 dst
->attr
.intent
= INTENT_INOUT
;
2576 gfc_set_sym_referenced (dst
);
2577 copy
->formal
->next
= gfc_get_formal_arglist ();
2578 copy
->formal
->next
->sym
= dst
;
2580 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2581 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2582 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2584 /* Set initializer. */
2585 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2586 c
->ts
.interface
= copy
;
2588 /* Add component _final. */
2589 if (!gfc_add_component (vtype
, "_final", &c
))
2591 c
->attr
.proc_pointer
= 1;
2592 c
->attr
.access
= ACCESS_PRIVATE
;
2593 c
->tb
= XCNEW (gfc_typebound_proc
);
2595 c
->initializer
= gfc_get_null_expr (NULL
);
2597 vtab
->ts
.u
.derived
= vtype
;
2598 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2605 /* It is unexpected to have some symbols added at resolution or code
2606 generation time. We commit the changes in order to keep a clean state. */
2609 gfc_commit_symbol (vtab
);
2611 gfc_commit_symbol (vtype
);
2613 gfc_commit_symbol (copy
);
2615 gfc_commit_symbol (src
);
2617 gfc_commit_symbol (dst
);
2620 gfc_undo_symbols ();
2626 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2629 gfc_find_vtab (gfc_typespec
*ts
)
2636 return gfc_find_derived_vtab (ts
->u
.derived
);
2638 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2640 return find_intrinsic_vtab (ts
);
2645 /* General worker function to find either a type-bound procedure or a
2646 type-bound user operator. */
2649 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2650 const char* name
, bool noaccess
, bool uop
,
2656 /* Set default to failure. */
2660 if (derived
->f2k_derived
)
2661 /* Set correct symbol-root. */
2662 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2663 : derived
->f2k_derived
->tb_sym_root
);
2667 /* Try to find it in the current type's namespace. */
2668 res
= gfc_find_symtree (root
, name
);
2669 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2675 if (!noaccess
&& derived
->attr
.use_assoc
2676 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2679 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2680 name
, derived
->name
, where
);
2688 /* Otherwise, recurse on parent type if derived is an extension. */
2689 if (derived
->attr
.extension
)
2691 gfc_symbol
* super_type
;
2692 super_type
= gfc_get_derived_super_type (derived
);
2693 gcc_assert (super_type
);
2695 return find_typebound_proc_uop (super_type
, t
, name
,
2696 noaccess
, uop
, where
);
2699 /* Nothing found. */
2704 /* Find a type-bound procedure or user operator by name for a derived-type
2705 (looking recursively through the super-types). */
2708 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2709 const char* name
, bool noaccess
, locus
* where
)
2711 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2715 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2716 const char* name
, bool noaccess
, locus
* where
)
2718 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2722 /* Find a type-bound intrinsic operator looking recursively through the
2723 super-type hierarchy. */
2726 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2727 gfc_intrinsic_op op
, bool noaccess
,
2730 gfc_typebound_proc
* res
;
2732 /* Set default to failure. */
2736 /* Try to find it in the current type's namespace. */
2737 if (derived
->f2k_derived
)
2738 res
= derived
->f2k_derived
->tb_op
[op
];
2743 if (res
&& !res
->error
)
2749 if (!noaccess
&& derived
->attr
.use_assoc
2750 && res
->access
== ACCESS_PRIVATE
)
2753 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2754 gfc_op2string (op
), derived
->name
, where
);
2762 /* Otherwise, recurse on parent type if derived is an extension. */
2763 if (derived
->attr
.extension
)
2765 gfc_symbol
* super_type
;
2766 super_type
= gfc_get_derived_super_type (derived
);
2767 gcc_assert (super_type
);
2769 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2773 /* Nothing found. */
2778 /* Get a typebound-procedure symtree or create and insert it if not yet
2779 present. This is like a very simplified version of gfc_get_sym_tree for
2780 tbp-symtrees rather than regular ones. */
2783 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2785 gfc_symtree
*result
;
2787 result
= gfc_find_symtree (*root
, name
);
2790 result
= gfc_new_symtree (root
, name
);
2791 gcc_assert (result
);
2792 result
->n
.tb
= NULL
;