1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009, 2010, 2011, 2012, 2013
3 Free Software Foundation, Inc.
4 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
5 and Janus Weil <janus@gcc.gnu.org>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* class.c -- This file contains the front end functions needed to service
25 the implementation of Fortran 2003 polymorphism and other
26 object-oriented features. */
29 /* Outline of the internal representation:
31 Each CLASS variable is encapsulated by a class container, which is a
32 structure with two fields:
33 * _data: A pointer to the actual data of the variable. This field has the
34 declared type of the class variable and its attributes
35 (pointer/allocatable/dimension/...).
36 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
38 For each derived type we set up a "vtable" entry, i.e. a structure with the
40 * _hash: A hash value serving as a unique identifier for this type.
41 * _size: The size in bytes of the derived type.
42 * _extends: A pointer to the vtable entry of the parent derived type.
43 * _def_init: A pointer to a default initialized variable of this type.
44 * _copy: A procedure pointer to a copying procedure.
45 * _final: A procedure pointer to a wrapper function, which frees
46 allocatable components and calls FINAL subroutines.
48 After these follow procedure pointer components for the specific
49 type-bound procedures. */
54 #include "coretypes.h"
56 #include "constructor.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 a NULL initializer for CLASS pointers,
417 initializing the _data component to NULL and
418 the _vptr component to the declared type. */
421 gfc_class_null_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
425 gfc_symbol
*vtab
= NULL
;
426 bool is_unlimited_polymorphic
;
428 is_unlimited_polymorphic
= ts
->u
.derived
429 && ts
->u
.derived
->components
->ts
.u
.derived
430 && ts
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
;
432 if (is_unlimited_polymorphic
&& init_expr
)
433 vtab
= gfc_find_intrinsic_vtab (&ts
->u
.derived
->components
->ts
);
435 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
437 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
438 &ts
->u
.derived
->declared_at
);
441 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
443 gfc_constructor
*ctor
= gfc_constructor_get();
444 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
445 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
447 ctor
->expr
= gfc_get_null_expr (NULL
);
448 gfc_constructor_append (&init
->value
.constructor
, ctor
);
455 /* Create a unique string identifier for a derived type, composed of its name
456 and module name. This is used to construct unique names for the class
457 containers and vtab symbols. */
460 get_unique_type_string (char *string
, gfc_symbol
*derived
)
462 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
463 if (derived
->attr
.unlimited_polymorphic
)
464 sprintf (dt_name
, "%s", "$tar");
466 sprintf (dt_name
, "%s", derived
->name
);
467 dt_name
[0] = TOUPPER (dt_name
[0]);
468 if (derived
->attr
.unlimited_polymorphic
)
469 sprintf (string
, "_%s", dt_name
);
470 else if (derived
->module
)
471 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
472 else if (derived
->ns
->proc_name
)
473 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
475 sprintf (string
, "_%s", dt_name
);
479 /* A relative of 'get_unique_type_string' which makes sure the generated
480 string will not be too long (replacing it by a hash string if needed). */
483 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
485 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
486 get_unique_type_string (&tmp
[0], derived
);
487 /* If string is too long, use hash value in hex representation (allow for
488 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
489 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
490 where %d is the (co)rank which can be up to n = 15. */
491 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
493 int h
= gfc_hash_value (derived
);
494 sprintf (string
, "%X", h
);
497 strcpy (string
, tmp
);
501 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
504 gfc_hash_value (gfc_symbol
*sym
)
506 unsigned int hash
= 0;
507 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
510 get_unique_type_string (&c
[0], sym
);
513 for (i
= 0; i
< len
; i
++)
514 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
516 /* Return the hash but take the modulus for the sake of module read,
517 even though this slightly increases the chance of collision. */
518 return (hash
% 100000000);
522 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
525 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
527 unsigned int hash
= 0;
528 const char *c
= gfc_typename (ts
);
533 for (i
= 0; i
< len
; i
++)
534 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
536 /* Return the hash but take the modulus for the sake of module read,
537 even though this slightly increases the chance of collision. */
538 return (hash
% 100000000);
542 /* Build a polymorphic CLASS entity, using the symbol that comes from
543 build_sym. A CLASS entity is represented by an encapsulating type,
544 which contains the declared type as '_data' component, plus a pointer
545 component '_vptr' which determines the dynamic type. */
548 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
549 gfc_array_spec
**as
, bool delayed_vtab
)
551 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
560 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
562 gfc_error ("Assumed size polymorphic objects or components, such "
563 "as that at %C, have not yet been implemented");
568 /* Class container has already been built. */
571 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
572 || attr
->select_type_temporary
;
575 /* We can not build the class container yet. */
578 /* Determine the name of the encapsulating type. */
579 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
580 get_unique_hashed_string (tname
, ts
->u
.derived
);
581 if ((*as
) && attr
->allocatable
)
582 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
583 else if ((*as
) && attr
->pointer
)
584 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
586 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
587 else if (attr
->pointer
)
588 sprintf (name
, "__class_%s_p", tname
);
589 else if (attr
->allocatable
)
590 sprintf (name
, "__class_%s_a", tname
);
592 sprintf (name
, "__class_%s", tname
);
594 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
596 /* Find the top-level namespace. */
597 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
602 ns
= ts
->u
.derived
->ns
;
604 gfc_find_symbol (name
, ns
, 0, &fclass
);
608 /* If not there, create a new symbol. */
609 fclass
= gfc_new_symbol (name
, ns
);
610 st
= gfc_new_symtree (&ns
->sym_root
, name
);
612 gfc_set_sym_referenced (fclass
);
614 fclass
->ts
.type
= BT_UNKNOWN
;
615 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
616 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
617 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
618 if (gfc_add_flavor (&fclass
->attr
, FL_DERIVED
,
619 NULL
, &gfc_current_locus
) == FAILURE
)
622 /* Add component '_data'. */
623 if (gfc_add_component (fclass
, "_data", &c
) == FAILURE
)
626 c
->ts
.type
= BT_DERIVED
;
627 c
->attr
.access
= ACCESS_PRIVATE
;
628 c
->ts
.u
.derived
= ts
->u
.derived
;
629 c
->attr
.class_pointer
= attr
->pointer
;
630 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
631 || attr
->select_type_temporary
;
632 c
->attr
.allocatable
= attr
->allocatable
;
633 c
->attr
.dimension
= attr
->dimension
;
634 c
->attr
.codimension
= attr
->codimension
;
635 c
->attr
.abstract
= fclass
->attr
.abstract
;
637 c
->initializer
= NULL
;
639 /* Add component '_vptr'. */
640 if (gfc_add_component (fclass
, "_vptr", &c
) == FAILURE
)
642 c
->ts
.type
= BT_DERIVED
;
644 || (ts
->u
.derived
->f2k_derived
645 && ts
->u
.derived
->f2k_derived
->finalizers
))
646 c
->ts
.u
.derived
= NULL
;
649 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
651 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
653 c
->attr
.access
= ACCESS_PRIVATE
;
657 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
659 /* Since the extension field is 8 bit wide, we can only have
660 up to 255 extension levels. */
661 if (ts
->u
.derived
->attr
.extension
== 255)
663 gfc_error ("Maximum extension level reached with type '%s' at %L",
664 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
668 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
669 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
672 fclass
->attr
.is_class
= 1;
673 ts
->u
.derived
= fclass
;
674 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
680 /* Add a procedure pointer component to the vtype
681 to represent a specific type-bound procedure. */
684 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
688 if (tb
->non_overridable
)
691 c
= gfc_find_component (vtype
, name
, true, true);
695 /* Add procedure component. */
696 if (gfc_add_component (vtype
, name
, &c
) == FAILURE
)
700 c
->tb
= XCNEW (gfc_typebound_proc
);
703 c
->attr
.procedure
= 1;
704 c
->attr
.proc_pointer
= 1;
705 c
->attr
.flavor
= FL_PROCEDURE
;
706 c
->attr
.access
= ACCESS_PRIVATE
;
707 c
->attr
.external
= 1;
709 c
->attr
.if_source
= IFSRC_IFBODY
;
711 else if (c
->attr
.proc_pointer
&& c
->tb
)
719 c
->ts
.interface
= tb
->u
.specific
->n
.sym
;
721 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
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
))
790 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
791 neither allocatable nor a pointer but has a finalizer, call it. If it
792 is a nonpointer component with allocatable components or has finalizers, walk
793 them. Either of them is required; other nonallocatables and pointers aren't
795 Note: If the component is allocatable, the DEALLOCATE handling takes care
796 of calling the appropriate finalizers, coarray deregistering, and
797 deallocation of allocatable subcomponents. */
800 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
801 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
)
806 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
807 && !comp
->attr
.allocatable
)
810 if ((comp
->ts
.type
== BT_DERIVED
&& comp
->attr
.pointer
)
811 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
812 && CLASS_DATA (comp
)->attr
.pointer
))
815 if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.allocatable
816 && (comp
->ts
.u
.derived
->f2k_derived
== NULL
817 || comp
->ts
.u
.derived
->f2k_derived
->finalizers
== NULL
)
818 && !has_finalizer_component (comp
->ts
.u
.derived
))
821 e
= gfc_copy_expr (expr
);
823 e
->ref
= ref
= gfc_get_ref ();
826 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
828 ref
->next
= gfc_get_ref ();
831 ref
->type
= REF_COMPONENT
;
832 ref
->u
.c
.sym
= derived
;
833 ref
->u
.c
.component
= comp
;
836 if (comp
->attr
.dimension
837 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
838 && CLASS_DATA (comp
)->attr
.dimension
))
840 ref
->next
= gfc_get_ref ();
841 ref
->next
->type
= REF_ARRAY
;
842 ref
->next
->u
.ar
.type
= AR_FULL
;
843 ref
->next
->u
.ar
.dimen
= 0;
844 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
846 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
849 /* Call DEALLOCATE (comp, stat=ignore). */
850 if (comp
->attr
.allocatable
851 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
852 && CLASS_DATA (comp
)->attr
.allocatable
))
854 gfc_code
*dealloc
, *block
= NULL
;
856 /* Add IF (fini_coarray). */
857 if (comp
->attr
.codimension
858 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
859 && CLASS_DATA (comp
)->attr
.allocatable
))
861 block
= XCNEW (gfc_code
);
864 (*code
)->next
= block
;
865 (*code
) = (*code
)->next
;
870 block
->loc
= gfc_current_locus
;
873 block
->block
= XCNEW (gfc_code
);
874 block
= block
->block
;
875 block
->loc
= gfc_current_locus
;
877 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
880 dealloc
= XCNEW (gfc_code
);
881 dealloc
->op
= EXEC_DEALLOCATE
;
882 dealloc
->loc
= gfc_current_locus
;
884 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
885 dealloc
->ext
.alloc
.list
->expr
= e
;
886 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
889 block
->next
= dealloc
;
892 (*code
)->next
= dealloc
;
893 (*code
) = (*code
)->next
;
898 else if (comp
->ts
.type
== BT_DERIVED
899 && comp
->ts
.u
.derived
->f2k_derived
900 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
902 /* Call FINAL_WRAPPER (comp); */
903 gfc_code
*final_wrap
;
907 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
908 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
909 if (strcmp (c
->name
, "_final") == 0)
913 final_wrap
= XCNEW (gfc_code
);
914 final_wrap
->op
= EXEC_CALL
;
915 final_wrap
->loc
= gfc_current_locus
;
916 final_wrap
->loc
= gfc_current_locus
;
917 final_wrap
->symtree
= c
->initializer
->symtree
;
918 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
919 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
920 final_wrap
->ext
.actual
->expr
= e
;
924 (*code
)->next
= final_wrap
;
925 (*code
) = (*code
)->next
;
928 (*code
) = final_wrap
;
934 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
935 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
941 /* Generate code equivalent to
942 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
943 + offset, c_ptr), ptr). */
946 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
947 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
950 gfc_expr
*expr
, *expr2
;
953 block
= XCNEW (gfc_code
);
954 block
->op
= EXEC_CALL
;
955 block
->loc
= gfc_current_locus
;
956 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
957 block
->resolved_sym
= block
->symtree
->n
.sym
;
958 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
959 block
->resolved_sym
->attr
.intrinsic
= 1;
960 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
961 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
962 gfc_commit_symbol (block
->resolved_sym
);
964 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
965 block
->ext
.actual
= gfc_get_actual_arglist ();
966 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
967 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
970 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
972 /* TRANSFER's first argument: C_LOC (array). */
973 expr
= gfc_get_expr ();
974 expr
->expr_type
= EXPR_FUNCTION
;
975 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
976 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
977 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
978 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
979 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
980 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
981 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
982 expr
->value
.function
.actual
->expr
983 = gfc_lval_expr_from_sym (array
);
984 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
985 gfc_commit_symbol (expr
->symtree
->n
.sym
);
986 expr
->ts
.type
= BT_INTEGER
;
987 expr
->ts
.kind
= gfc_index_integer_kind
;
990 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
991 gfc_current_locus
, 2, expr
,
992 gfc_get_int_expr (gfc_index_integer_kind
,
994 expr2
->ts
.type
= BT_INTEGER
;
995 expr2
->ts
.kind
= gfc_index_integer_kind
;
997 /* <array addr> + <offset>. */
998 block
->ext
.actual
->expr
= gfc_get_expr ();
999 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1000 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1001 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1002 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1003 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1005 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1006 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1007 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1008 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1014 /* Calculates the offset to the (idx+1)th element of an array, taking the
1015 stride into account. It generates the code:
1018 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1020 offset = offset * byte_stride. */
1023 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1024 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1025 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1026 gfc_code
*block
, gfc_namespace
*sub_ns
)
1029 gfc_expr
*expr
, *expr2
;
1032 block
->next
= XCNEW (gfc_code
);
1033 block
= block
->next
;
1034 block
->op
= EXEC_ASSIGN
;
1035 block
->loc
= gfc_current_locus
;
1036 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1037 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1040 iter
= gfc_get_iterator ();
1041 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1042 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1043 iter
->end
= gfc_copy_expr (rank
);
1044 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1045 block
->next
= XCNEW (gfc_code
);
1046 block
= block
->next
;
1047 block
->op
= EXEC_DO
;
1048 block
->loc
= gfc_current_locus
;
1049 block
->ext
.iterator
= iter
;
1050 block
->block
= gfc_get_code ();
1051 block
->block
->op
= EXEC_DO
;
1053 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1056 /* mod (idx, sizes(idx2)). */
1057 expr
= gfc_lval_expr_from_sym (sizes
);
1058 expr
->ref
= gfc_get_ref ();
1059 expr
->ref
->type
= REF_ARRAY
;
1060 expr
->ref
->u
.ar
.as
= sizes
->as
;
1061 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1062 expr
->ref
->u
.ar
.dimen
= 1;
1063 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1064 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1066 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1067 gfc_current_locus
, 2,
1068 gfc_lval_expr_from_sym (idx
), expr
);
1071 /* (...) / sizes(idx2-1). */
1072 expr2
= gfc_get_expr ();
1073 expr2
->expr_type
= EXPR_OP
;
1074 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1075 expr2
->value
.op
.op1
= expr
;
1076 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1077 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1078 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1079 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1080 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1081 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1082 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1083 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1084 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1085 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1086 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1087 = gfc_lval_expr_from_sym (idx2
);
1088 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1089 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1090 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1091 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1092 expr2
->ts
= idx
->ts
;
1094 /* ... * strides(idx2). */
1095 expr
= gfc_get_expr ();
1096 expr
->expr_type
= EXPR_OP
;
1097 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1098 expr
->value
.op
.op1
= expr2
;
1099 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1100 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1101 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1102 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1103 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1104 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1105 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1106 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1109 /* offset = offset + ... */
1110 block
->block
->next
= XCNEW (gfc_code
);
1111 block
->block
->next
->op
= EXEC_ASSIGN
;
1112 block
->block
->next
->loc
= gfc_current_locus
;
1113 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1114 block
->block
->next
->expr2
= gfc_get_expr ();
1115 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1116 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1117 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1118 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1119 block
->block
->next
->expr2
->ts
= idx
->ts
;
1121 /* After the loop: offset = offset * byte_stride. */
1122 block
->next
= XCNEW (gfc_code
);
1123 block
= block
->next
;
1124 block
->op
= EXEC_ASSIGN
;
1125 block
->loc
= gfc_current_locus
;
1126 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1127 block
->expr2
= gfc_get_expr ();
1128 block
->expr2
->expr_type
= EXPR_OP
;
1129 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1130 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1131 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1132 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1137 /* Insert code of the following form:
1140 integer(c_intptr_t) :: i
1142 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1143 && (is_contiguous || !final_rank3->attr.contiguous
1144 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1145 || 0 == STORAGE_SIZE (array)) then
1146 call final_rank3 (array)
1149 integer(c_intptr_t) :: offset, j
1150 type(t) :: tmp(shape (array))
1152 do i = 0, size (array)-1
1153 offset = obtain_offset(i, strides, sizes, byte_stride)
1154 addr = transfer (c_loc (array), addr) + offset
1155 call c_f_pointer (transfer (addr, cptr), ptr)
1157 addr = transfer (c_loc (tmp), addr)
1158 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1159 call c_f_pointer (transfer (addr, cptr), ptr2)
1162 call final_rank3 (tmp)
1168 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1169 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1170 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1172 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1173 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1174 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1175 gfc_namespace
*sub_ns
)
1177 gfc_symbol
*tmp_array
, *ptr2
;
1178 gfc_expr
*size_expr
, *offset2
, *expr
;
1184 block
->next
= XCNEW (gfc_code
);
1185 block
= block
->next
;
1186 block
->loc
= gfc_current_locus
;
1187 block
->op
= EXEC_IF
;
1189 block
->block
= XCNEW (gfc_code
);
1190 block
= block
->block
;
1191 block
->loc
= gfc_current_locus
;
1192 block
->op
= EXEC_IF
;
1194 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1195 size_expr
= gfc_get_expr ();
1196 size_expr
->where
= gfc_current_locus
;
1197 size_expr
->expr_type
= EXPR_OP
;
1198 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1200 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1201 size_expr
->value
.op
.op1
1202 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1203 "storage_size", gfc_current_locus
, 2,
1204 gfc_lval_expr_from_sym (array
));
1205 gfc_get_int_expr (gfc_index_integer_kind
,
1208 /* NUMERIC_STORAGE_SIZE. */
1209 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1210 gfc_character_storage_size
);
1211 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1212 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1214 /* IF condition: (stride == size_expr
1215 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1217 || 0 == size_expr. */
1218 block
->expr1
= gfc_get_expr ();
1219 block
->expr1
->expr_type
= EXPR_FUNCTION
;
1220 block
->expr1
->ts
.type
= BT_LOGICAL
;
1221 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1222 block
->expr1
->expr_type
= EXPR_OP
;
1223 block
->expr1
->where
= gfc_current_locus
;
1225 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1227 /* byte_stride == size_expr */
1228 expr
= gfc_get_expr ();
1229 expr
->ts
.type
= BT_LOGICAL
;
1230 expr
->ts
.kind
= gfc_default_logical_kind
;
1231 expr
->expr_type
= EXPR_OP
;
1232 expr
->where
= gfc_current_locus
;
1233 expr
->value
.op
.op
= INTRINSIC_EQ
;
1235 = gfc_lval_expr_from_sym (byte_stride
);
1236 expr
->value
.op
.op2
= size_expr
;
1238 /* If strides aren't allowd (not assumed shape or CONTIGUOUS),
1239 add is_contiguous check. */
1240 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1241 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1244 expr2
= gfc_get_expr ();
1245 expr2
->ts
.type
= BT_LOGICAL
;
1246 expr2
->ts
.kind
= gfc_default_logical_kind
;
1247 expr2
->expr_type
= EXPR_OP
;
1248 expr2
->where
= gfc_current_locus
;
1249 expr2
->value
.op
.op
= INTRINSIC_AND
;
1250 expr2
->value
.op
.op1
= expr
;
1251 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1255 block
->expr1
->value
.op
.op1
= expr
;
1257 /* 0 == size_expr */
1258 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1259 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1260 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1261 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1262 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1263 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1264 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1265 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1266 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1268 /* IF body: call final subroutine. */
1269 block
->next
= XCNEW (gfc_code
);
1270 block
->next
->op
= EXEC_CALL
;
1271 block
->next
->loc
= gfc_current_locus
;
1272 block
->next
->symtree
= fini
->proc_tree
;
1273 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1274 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1275 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1279 block
->block
= XCNEW (gfc_code
);
1280 block
= block
->block
;
1281 block
->loc
= gfc_current_locus
;
1282 block
->op
= EXEC_IF
;
1284 block
->next
= XCNEW (gfc_code
);
1285 block
= block
->next
;
1287 /* BLOCK ... END BLOCK. */
1288 block
->op
= EXEC_BLOCK
;
1289 block
->loc
= gfc_current_locus
;
1290 ns
= gfc_build_block_ns (sub_ns
);
1291 block
->ext
.block
.ns
= ns
;
1292 block
->ext
.block
.assoc
= NULL
;
1294 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1295 ptr2
->ts
.type
= BT_DERIVED
;
1296 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1297 ptr2
->attr
.flavor
= FL_VARIABLE
;
1298 ptr2
->attr
.pointer
= 1;
1299 ptr2
->attr
.artificial
= 1;
1300 gfc_set_sym_referenced (ptr2
);
1301 gfc_commit_symbol (ptr2
);
1303 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1304 tmp_array
->ts
.type
= BT_DERIVED
;
1305 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1306 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1307 tmp_array
->attr
.dimension
= 1;
1308 tmp_array
->attr
.artificial
= 1;
1309 tmp_array
->as
= gfc_get_array_spec();
1310 tmp_array
->attr
.intent
= INTENT_INOUT
;
1311 tmp_array
->as
->type
= AS_EXPLICIT
;
1312 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1314 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1316 gfc_expr
*shape_expr
;
1317 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1319 /* SIZE (array, dim=i+1, kind=default_kind). */
1321 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1322 gfc_current_locus
, 3,
1323 gfc_lval_expr_from_sym (array
),
1324 gfc_get_int_expr (gfc_default_integer_kind
,
1326 gfc_get_int_expr (gfc_default_integer_kind
,
1328 tmp_array
->as
->upper
[i
] = shape_expr
;
1330 gfc_set_sym_referenced (tmp_array
);
1331 gfc_commit_symbol (tmp_array
);
1334 iter
= gfc_get_iterator ();
1335 iter
->var
= gfc_lval_expr_from_sym (idx
);
1336 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1337 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1338 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1340 block
= XCNEW (gfc_code
);
1342 block
->op
= EXEC_DO
;
1343 block
->loc
= gfc_current_locus
;
1344 block
->ext
.iterator
= iter
;
1345 block
->block
= gfc_get_code ();
1346 block
->block
->op
= EXEC_DO
;
1348 /* Offset calculation for the new array: idx * size of type (in bytes). */
1349 offset2
= gfc_get_expr ();
1350 offset2
= block
->ext
.actual
->expr
;
1351 offset2
->expr_type
= EXPR_OP
;
1352 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1353 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1354 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1355 offset2
->ts
= byte_stride
->ts
;
1357 /* Offset calculation of "array". */
1358 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1359 byte_stride
, rank
, block
->block
, sub_ns
);
1362 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1363 + idx * stride, c_ptr), ptr). */
1364 block2
->next
= finalization_scalarizer (array
, ptr
,
1365 gfc_lval_expr_from_sym (offset
),
1367 block2
= block2
->next
;
1368 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1371 block2
->next
= XCNEW (gfc_code
);
1372 block2
->next
->op
= EXEC_ASSIGN
;
1373 block2
->next
->loc
= gfc_current_locus
;
1374 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1375 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr
);
1377 /* Call now the user's final subroutine. */
1378 block
->next
= XCNEW (gfc_code
);
1379 block
= block
->next
;
1380 block
->op
= EXEC_CALL
;
1381 block
->loc
= gfc_current_locus
;
1382 block
->symtree
= fini
->proc_tree
;
1383 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1384 block
->ext
.actual
= gfc_get_actual_arglist ();
1385 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1387 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1393 iter
= gfc_get_iterator ();
1394 iter
->var
= gfc_lval_expr_from_sym (idx
);
1395 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1396 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1397 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1399 block
->next
= XCNEW (gfc_code
);
1400 block
= block
->next
;
1401 block
->op
= EXEC_DO
;
1402 block
->loc
= gfc_current_locus
;
1403 block
->ext
.iterator
= iter
;
1404 block
->block
= gfc_get_code ();
1405 block
->block
->op
= EXEC_DO
;
1407 /* Offset calculation of "array". */
1408 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1409 byte_stride
, rank
, block
->block
, sub_ns
);
1412 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1413 + offset, c_ptr), ptr). */
1414 block2
->next
= finalization_scalarizer (array
, ptr
,
1415 gfc_lval_expr_from_sym (offset
),
1417 block2
= block2
->next
;
1418 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1419 block2
= block2
->next
;
1422 block2
->next
= XCNEW (gfc_code
);
1423 block2
->next
->op
= EXEC_ASSIGN
;
1424 block2
->next
->loc
= gfc_current_locus
;
1425 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1426 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1430 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1431 derived type "derived". The function first calls the approriate FINAL
1432 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1433 components (but not the inherited ones). Last, it calls the wrapper
1434 subroutine of the parent. The generated wrapper procedure takes as argument
1435 an assumed-rank array.
1436 If neither allocatable components nor FINAL subroutines exists, the vtab
1437 will contain a NULL pointer.
1438 The generated function has the form
1439 _final(assumed-rank array, stride, skip_corarray)
1440 where the array has to be contiguous (except of the lowest dimension). The
1441 stride (in bytes) is used to allow different sizes for ancestor types by
1442 skipping over the additionally added components in the scalarizer. If
1443 "fini_coarray" is false, coarray components are not finalized to allow for
1444 the correct semantic with intrinsic assignment. */
1447 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1448 const char *tname
, gfc_component
*vtab_final
)
1450 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1451 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1452 gfc_component
*comp
;
1453 gfc_namespace
*sub_ns
;
1454 gfc_code
*last_code
, *block
;
1455 char name
[GFC_MAX_SYMBOL_LEN
+1];
1456 bool finalizable_comp
= false;
1457 bool expr_null_wrapper
= false;
1458 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1461 /* Search for the ancestor's finalizers. */
1462 if (derived
->attr
.extension
&& derived
->components
1463 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1464 || has_finalizer_component (derived
)))
1467 gfc_component
*comp
;
1469 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1470 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1471 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1473 ancestor_wrapper
= comp
->initializer
;
1478 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1479 components: Return a NULL() expression; we defer this a bit to have have
1480 an interface declaration. */
1481 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1482 && !derived
->attr
.alloc_comp
1483 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1484 && !has_finalizer_component (derived
))
1485 expr_null_wrapper
= true;
1487 /* Check whether there are new allocatable components. */
1488 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1490 if (comp
== derived
->components
&& derived
->attr
.extension
1491 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1494 if (comp
->ts
.type
!= BT_CLASS
&& !comp
->attr
.pointer
1495 && (comp
->attr
.allocatable
1496 || (comp
->ts
.type
== BT_DERIVED
1497 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1498 || has_finalizer_component (comp
->ts
.u
.derived
)
1499 || (comp
->ts
.u
.derived
->f2k_derived
1500 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))))
1501 finalizable_comp
= true;
1502 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1503 && CLASS_DATA (comp
)->attr
.allocatable
)
1504 finalizable_comp
= true;
1507 /* If there is no new finalizer and no new allocatable, return with
1508 an expr to the ancestor's one. */
1509 if (!expr_null_wrapper
&& !finalizable_comp
1510 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1512 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1513 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1514 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1515 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1519 /* We now create a wrapper, which does the following:
1520 1. Call the suitable finalization subroutine for this type
1521 2. Loop over all noninherited allocatable components and noninherited
1522 components with allocatable components and DEALLOCATE those; this will
1523 take care of finalizers, coarray deregistering and allocatable
1525 3. Call the ancestor's finalizer. */
1527 /* Declare the wrapper function; it takes an assumed-rank array
1528 and a VALUE logical as arguments. */
1530 /* Set up the namespace. */
1531 sub_ns
= gfc_get_namespace (ns
, 0);
1532 sub_ns
->sibling
= ns
->contained
;
1533 if (!expr_null_wrapper
)
1534 ns
->contained
= sub_ns
;
1535 sub_ns
->resolved
= 1;
1537 /* Set up the procedure symbol. */
1538 sprintf (name
, "__final_%s", tname
);
1539 gfc_get_symbol (name
, sub_ns
, &final
);
1540 sub_ns
->proc_name
= final
;
1541 final
->attr
.flavor
= FL_PROCEDURE
;
1542 final
->attr
.function
= 1;
1543 final
->attr
.pure
= 0;
1544 final
->result
= final
;
1545 final
->ts
.type
= BT_INTEGER
;
1547 final
->attr
.artificial
= 1;
1548 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1549 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1550 final
->module
= ns
->proc_name
->name
;
1551 gfc_set_sym_referenced (final
);
1552 gfc_commit_symbol (final
);
1554 /* Set up formal argument. */
1555 gfc_get_symbol ("array", sub_ns
, &array
);
1556 array
->ts
.type
= BT_DERIVED
;
1557 array
->ts
.u
.derived
= derived
;
1558 array
->attr
.flavor
= FL_VARIABLE
;
1559 array
->attr
.dummy
= 1;
1560 array
->attr
.contiguous
= 1;
1561 array
->attr
.dimension
= 1;
1562 array
->attr
.artificial
= 1;
1563 array
->as
= gfc_get_array_spec();
1564 array
->as
->type
= AS_ASSUMED_RANK
;
1565 array
->as
->rank
= -1;
1566 array
->attr
.intent
= INTENT_INOUT
;
1567 gfc_set_sym_referenced (array
);
1568 final
->formal
= gfc_get_formal_arglist ();
1569 final
->formal
->sym
= array
;
1570 gfc_commit_symbol (array
);
1572 /* Set up formal argument. */
1573 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1574 byte_stride
->ts
.type
= BT_INTEGER
;
1575 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1576 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1577 byte_stride
->attr
.dummy
= 1;
1578 byte_stride
->attr
.value
= 1;
1579 byte_stride
->attr
.artificial
= 1;
1580 gfc_set_sym_referenced (byte_stride
);
1581 final
->formal
->next
= gfc_get_formal_arglist ();
1582 final
->formal
->next
->sym
= byte_stride
;
1583 gfc_commit_symbol (byte_stride
);
1585 /* Set up formal argument. */
1586 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1587 fini_coarray
->ts
.type
= BT_LOGICAL
;
1588 fini_coarray
->ts
.kind
= 1;
1589 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1590 fini_coarray
->attr
.dummy
= 1;
1591 fini_coarray
->attr
.value
= 1;
1592 fini_coarray
->attr
.artificial
= 1;
1593 gfc_set_sym_referenced (fini_coarray
);
1594 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1595 final
->formal
->next
->next
->sym
= fini_coarray
;
1596 gfc_commit_symbol (fini_coarray
);
1598 /* Return with a NULL() expression but with an interface which has
1599 the formal arguments. */
1600 if (expr_null_wrapper
)
1602 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1603 vtab_final
->ts
.interface
= final
;
1607 /* Local variables. */
1609 gfc_get_symbol ("idx", sub_ns
, &idx
);
1610 idx
->ts
.type
= BT_INTEGER
;
1611 idx
->ts
.kind
= gfc_index_integer_kind
;
1612 idx
->attr
.flavor
= FL_VARIABLE
;
1613 idx
->attr
.artificial
= 1;
1614 gfc_set_sym_referenced (idx
);
1615 gfc_commit_symbol (idx
);
1617 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1618 idx2
->ts
.type
= BT_INTEGER
;
1619 idx2
->ts
.kind
= gfc_index_integer_kind
;
1620 idx2
->attr
.flavor
= FL_VARIABLE
;
1621 idx2
->attr
.artificial
= 1;
1622 gfc_set_sym_referenced (idx2
);
1623 gfc_commit_symbol (idx2
);
1625 gfc_get_symbol ("offset", sub_ns
, &offset
);
1626 offset
->ts
.type
= BT_INTEGER
;
1627 offset
->ts
.kind
= gfc_index_integer_kind
;
1628 offset
->attr
.flavor
= FL_VARIABLE
;
1629 offset
->attr
.artificial
= 1;
1630 gfc_set_sym_referenced (offset
);
1631 gfc_commit_symbol (offset
);
1633 /* Create RANK expression. */
1634 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1635 gfc_current_locus
, 1,
1636 gfc_lval_expr_from_sym (array
));
1637 gfc_convert_type (rank
, &idx
->ts
, 2);
1639 /* Create is_contiguous variable. */
1640 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1641 is_contiguous
->ts
.type
= BT_LOGICAL
;
1642 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1643 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1644 is_contiguous
->attr
.artificial
= 1;
1645 gfc_set_sym_referenced (is_contiguous
);
1646 gfc_commit_symbol (is_contiguous
);
1648 /* Create "sizes(0..rank)" variable, which contains the multiplied
1649 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1650 sizes(2) = sizes(1) * extent(dim=2) etc. */
1651 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1652 sizes
->ts
.type
= BT_INTEGER
;
1653 sizes
->ts
.kind
= gfc_index_integer_kind
;
1654 sizes
->attr
.flavor
= FL_VARIABLE
;
1655 sizes
->attr
.dimension
= 1;
1656 sizes
->attr
.artificial
= 1;
1657 sizes
->as
= gfc_get_array_spec();
1658 sizes
->attr
.intent
= INTENT_INOUT
;
1659 sizes
->as
->type
= AS_EXPLICIT
;
1660 sizes
->as
->rank
= 1;
1661 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1662 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1663 gfc_set_sym_referenced (sizes
);
1664 gfc_commit_symbol (sizes
);
1666 /* Create "strides(1..rank)" variable, which contains the strides per
1668 gfc_get_symbol ("strides", sub_ns
, &strides
);
1669 strides
->ts
.type
= BT_INTEGER
;
1670 strides
->ts
.kind
= gfc_index_integer_kind
;
1671 strides
->attr
.flavor
= FL_VARIABLE
;
1672 strides
->attr
.dimension
= 1;
1673 strides
->attr
.artificial
= 1;
1674 strides
->as
= gfc_get_array_spec();
1675 strides
->attr
.intent
= INTENT_INOUT
;
1676 strides
->as
->type
= AS_EXPLICIT
;
1677 strides
->as
->rank
= 1;
1678 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1679 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1680 gfc_set_sym_referenced (strides
);
1681 gfc_commit_symbol (strides
);
1684 /* Set return value to 0. */
1685 last_code
= XCNEW (gfc_code
);
1686 last_code
->op
= EXEC_ASSIGN
;
1687 last_code
->loc
= gfc_current_locus
;
1688 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1689 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1690 sub_ns
->code
= last_code
;
1692 /* Set: is_contiguous = .true. */
1693 last_code
->next
= XCNEW (gfc_code
);
1694 last_code
= last_code
->next
;
1695 last_code
->op
= EXEC_ASSIGN
;
1696 last_code
->loc
= gfc_current_locus
;
1697 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1698 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1699 &gfc_current_locus
, true);
1701 /* Set: sizes(0) = 1. */
1702 last_code
->next
= XCNEW (gfc_code
);
1703 last_code
= last_code
->next
;
1704 last_code
->op
= EXEC_ASSIGN
;
1705 last_code
->loc
= gfc_current_locus
;
1706 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1707 last_code
->expr1
->ref
= gfc_get_ref ();
1708 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1709 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1710 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1711 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1712 last_code
->expr1
->ref
->u
.ar
.start
[0]
1713 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1714 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1715 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1719 strides(idx) = _F._stride (array, dim=idx)
1720 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1721 if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
1725 iter
= gfc_get_iterator ();
1726 iter
->var
= gfc_lval_expr_from_sym (idx
);
1727 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1728 iter
->end
= gfc_copy_expr (rank
);
1729 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1730 last_code
->next
= XCNEW (gfc_code
);
1731 last_code
= last_code
->next
;
1732 last_code
->op
= EXEC_DO
;
1733 last_code
->loc
= gfc_current_locus
;
1734 last_code
->ext
.iterator
= iter
;
1735 last_code
->block
= gfc_get_code ();
1736 last_code
->block
->op
= EXEC_DO
;
1738 /* strides(idx) = _F._stride(array,dim=idx). */
1739 last_code
->block
->next
= XCNEW (gfc_code
);
1740 block
= last_code
->block
->next
;
1741 block
->op
= EXEC_ASSIGN
;
1742 block
->loc
= gfc_current_locus
;
1744 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1745 block
->expr1
->ref
= gfc_get_ref ();
1746 block
->expr1
->ref
->type
= REF_ARRAY
;
1747 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1748 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1749 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1750 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1751 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1753 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1754 gfc_current_locus
, 2,
1755 gfc_lval_expr_from_sym (array
),
1756 gfc_lval_expr_from_sym (idx
));
1758 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1759 block
->next
= XCNEW (gfc_code
);
1760 block
= block
->next
;
1761 block
->op
= EXEC_ASSIGN
;
1762 block
->loc
= gfc_current_locus
;
1764 /* sizes(idx) = ... */
1765 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1766 block
->expr1
->ref
= gfc_get_ref ();
1767 block
->expr1
->ref
->type
= REF_ARRAY
;
1768 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1769 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1770 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1771 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1772 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1774 block
->expr2
= gfc_get_expr ();
1775 block
->expr2
->expr_type
= EXPR_OP
;
1776 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1779 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1780 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1781 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1782 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1783 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1784 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1785 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1786 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1787 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1788 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1789 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1790 = gfc_lval_expr_from_sym (idx
);
1791 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1792 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1793 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1794 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1796 /* size(array, dim=idx, kind=index_kind). */
1797 block
->expr2
->value
.op
.op2
1798 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1799 gfc_current_locus
, 3,
1800 gfc_lval_expr_from_sym (array
),
1801 gfc_lval_expr_from_sym (idx
),
1802 gfc_get_int_expr (gfc_index_integer_kind
,
1804 block
->expr2
->ts
= idx
->ts
;
1806 /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
1807 block
->next
= XCNEW (gfc_code
);
1808 block
= block
->next
;
1809 block
->loc
= gfc_current_locus
;
1810 block
->op
= EXEC_IF
;
1812 block
->block
= XCNEW (gfc_code
);
1813 block
= block
->block
;
1814 block
->loc
= gfc_current_locus
;
1815 block
->op
= EXEC_IF
;
1817 /* if condition: strides(idx) /= sizes(idx-1). */
1818 block
->expr1
= gfc_get_expr ();
1819 block
->expr1
->ts
.type
= BT_LOGICAL
;
1820 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1821 block
->expr1
->expr_type
= EXPR_OP
;
1822 block
->expr1
->where
= gfc_current_locus
;
1823 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1825 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1826 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1827 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1828 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1829 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1830 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1831 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1832 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1834 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1835 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1836 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1837 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1838 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1839 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1840 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1841 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1842 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1843 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1844 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1845 = gfc_lval_expr_from_sym (idx
);
1846 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1847 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1848 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1849 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1851 /* if body: is_contiguous = .false. */
1852 block
->next
= XCNEW (gfc_code
);
1853 block
= block
->next
;
1854 block
->op
= EXEC_ASSIGN
;
1855 block
->loc
= gfc_current_locus
;
1856 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1857 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1858 &gfc_current_locus
, false);
1860 /* Obtain the size (number of elements) of "array" MINUS ONE,
1861 which is used in the scalarization. */
1862 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1863 nelem
->ts
.type
= BT_INTEGER
;
1864 nelem
->ts
.kind
= gfc_index_integer_kind
;
1865 nelem
->attr
.flavor
= FL_VARIABLE
;
1866 nelem
->attr
.artificial
= 1;
1867 gfc_set_sym_referenced (nelem
);
1868 gfc_commit_symbol (nelem
);
1870 /* nelem = sizes (rank) - 1. */
1871 last_code
->next
= XCNEW (gfc_code
);
1872 last_code
= last_code
->next
;
1873 last_code
->op
= EXEC_ASSIGN
;
1874 last_code
->loc
= gfc_current_locus
;
1876 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1878 last_code
->expr2
= gfc_get_expr ();
1879 last_code
->expr2
->expr_type
= EXPR_OP
;
1880 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1881 last_code
->expr2
->value
.op
.op2
1882 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1883 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1885 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1886 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1887 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1888 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1889 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1890 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1891 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1892 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1894 /* Call final subroutines. We now generate code like:
1896 integer, pointer :: ptr
1898 integer(c_intptr_t) :: i, addr
1900 select case (rank (array))
1902 ! If needed, the array is packed
1903 call final_rank3 (array)
1905 do i = 0, size (array)-1
1906 addr = transfer (c_loc (array), addr) + i * stride
1907 call c_f_pointer (transfer (addr, cptr), ptr)
1908 call elemental_final (ptr)
1912 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1914 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1916 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1917 ptr
->ts
.type
= BT_DERIVED
;
1918 ptr
->ts
.u
.derived
= derived
;
1919 ptr
->attr
.flavor
= FL_VARIABLE
;
1920 ptr
->attr
.pointer
= 1;
1921 ptr
->attr
.artificial
= 1;
1922 gfc_set_sym_referenced (ptr
);
1923 gfc_commit_symbol (ptr
);
1925 /* SELECT CASE (RANK (array)). */
1926 last_code
->next
= XCNEW (gfc_code
);
1927 last_code
= last_code
->next
;
1928 last_code
->op
= EXEC_SELECT
;
1929 last_code
->loc
= gfc_current_locus
;
1930 last_code
->expr1
= gfc_copy_expr (rank
);
1933 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1935 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1941 /* CASE (fini_rank). */
1944 block
->block
= XCNEW (gfc_code
);
1945 block
= block
->block
;
1949 block
= XCNEW (gfc_code
);
1950 last_code
->block
= block
;
1952 block
->loc
= gfc_current_locus
;
1953 block
->op
= EXEC_SELECT
;
1954 block
->ext
.block
.case_list
= gfc_get_case ();
1955 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1956 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1957 block
->ext
.block
.case_list
->low
1958 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1959 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1961 block
->ext
.block
.case_list
->low
1962 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1963 block
->ext
.block
.case_list
->high
1964 = block
->ext
.block
.case_list
->low
;
1966 /* CALL fini_rank (array) - possibly with packing. */
1967 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1968 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1969 idx
, ptr
, nelem
, strides
,
1970 sizes
, idx2
, offset
, is_contiguous
,
1974 block
->next
= XCNEW (gfc_code
);
1975 block
->next
->op
= EXEC_CALL
;
1976 block
->next
->loc
= gfc_current_locus
;
1977 block
->next
->symtree
= fini
->proc_tree
;
1978 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1979 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1980 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1984 /* Elemental call - scalarized. */
1990 block
->block
= XCNEW (gfc_code
);
1991 block
= block
->block
;
1995 block
= XCNEW (gfc_code
);
1996 last_code
->block
= block
;
1998 block
->loc
= gfc_current_locus
;
1999 block
->op
= EXEC_SELECT
;
2000 block
->ext
.block
.case_list
= gfc_get_case ();
2003 iter
= gfc_get_iterator ();
2004 iter
->var
= gfc_lval_expr_from_sym (idx
);
2005 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2006 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2007 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2008 block
->next
= XCNEW (gfc_code
);
2009 block
= block
->next
;
2010 block
->op
= EXEC_DO
;
2011 block
->loc
= gfc_current_locus
;
2012 block
->ext
.iterator
= iter
;
2013 block
->block
= gfc_get_code ();
2014 block
->block
->op
= EXEC_DO
;
2016 /* Offset calculation. */
2017 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2018 byte_stride
, rank
, block
->block
,
2022 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2023 + offset, c_ptr), ptr). */
2025 = finalization_scalarizer (array
, ptr
,
2026 gfc_lval_expr_from_sym (offset
),
2028 block
= block
->next
;
2030 /* CALL final_elemental (array). */
2031 block
->next
= XCNEW (gfc_code
);
2032 block
= block
->next
;
2033 block
->op
= EXEC_CALL
;
2034 block
->loc
= gfc_current_locus
;
2035 block
->symtree
= fini_elem
->proc_tree
;
2036 block
->resolved_sym
= fini_elem
->proc_sym
;
2037 block
->ext
.actual
= gfc_get_actual_arglist ();
2038 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2042 /* Finalize and deallocate allocatable components. The same manual
2043 scalarization is used as above. */
2045 if (finalizable_comp
)
2048 gfc_code
*block
= NULL
;
2052 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2053 ptr
->ts
.type
= BT_DERIVED
;
2054 ptr
->ts
.u
.derived
= derived
;
2055 ptr
->attr
.flavor
= FL_VARIABLE
;
2056 ptr
->attr
.pointer
= 1;
2057 ptr
->attr
.artificial
= 1;
2058 gfc_set_sym_referenced (ptr
);
2059 gfc_commit_symbol (ptr
);
2062 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2063 stat
->attr
.flavor
= FL_VARIABLE
;
2064 stat
->attr
.artificial
= 1;
2065 stat
->ts
.type
= BT_INTEGER
;
2066 stat
->ts
.kind
= gfc_default_integer_kind
;
2067 gfc_set_sym_referenced (stat
);
2068 gfc_commit_symbol (stat
);
2071 iter
= gfc_get_iterator ();
2072 iter
->var
= gfc_lval_expr_from_sym (idx
);
2073 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2074 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2075 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2076 last_code
->next
= XCNEW (gfc_code
);
2077 last_code
= last_code
->next
;
2078 last_code
->op
= EXEC_DO
;
2079 last_code
->loc
= gfc_current_locus
;
2080 last_code
->ext
.iterator
= iter
;
2081 last_code
->block
= gfc_get_code ();
2082 last_code
->block
->op
= EXEC_DO
;
2084 /* Offset calculation. */
2085 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2086 byte_stride
, rank
, last_code
->block
,
2090 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2091 + idx * stride, c_ptr), ptr). */
2092 block
->next
= finalization_scalarizer (array
, ptr
,
2093 gfc_lval_expr_from_sym(offset
),
2095 block
= block
->next
;
2097 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2099 if (comp
== derived
->components
&& derived
->attr
.extension
2100 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2103 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2104 stat
, fini_coarray
, &block
);
2105 if (!last_code
->block
->next
)
2106 last_code
->block
->next
= block
;
2111 /* Call the finalizer of the ancestor. */
2112 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2114 last_code
->next
= XCNEW (gfc_code
);
2115 last_code
= last_code
->next
;
2116 last_code
->op
= EXEC_CALL
;
2117 last_code
->loc
= gfc_current_locus
;
2118 last_code
->symtree
= ancestor_wrapper
->symtree
;
2119 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2121 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2122 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2123 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2124 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2125 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2126 last_code
->ext
.actual
->next
->next
->expr
2127 = gfc_lval_expr_from_sym (fini_coarray
);
2130 gfc_free_expr (rank
);
2131 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2132 vtab_final
->ts
.interface
= final
;
2136 /* Add procedure pointers for all type-bound procedures to a vtab. */
2139 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2141 gfc_symbol
* super_type
;
2143 super_type
= gfc_get_derived_super_type (derived
);
2145 if (super_type
&& (super_type
!= derived
))
2147 /* Make sure that the PPCs appear in the same order as in the parent. */
2148 copy_vtab_proc_comps (super_type
, vtype
);
2149 /* Only needed to get the PPC initializers right. */
2150 add_procs_to_declared_vtab (super_type
, vtype
);
2153 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2154 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2156 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2157 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2161 /* Find or generate the symbol for a derived type's vtab. */
2164 gfc_find_derived_vtab (gfc_symbol
*derived
)
2167 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2168 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2170 /* Find the top-level namespace. */
2171 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2175 /* If the type is a class container, use the underlying derived type. */
2176 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2177 derived
= gfc_get_derived_super_type (derived
);
2181 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2183 get_unique_hashed_string (tname
, derived
);
2184 sprintf (name
, "__vtab_%s", tname
);
2186 /* Look for the vtab symbol in various namespaces. */
2187 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2189 gfc_find_symbol (name
, ns
, 0, &vtab
);
2191 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2195 gfc_get_symbol (name
, ns
, &vtab
);
2196 vtab
->ts
.type
= BT_DERIVED
;
2197 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2198 &gfc_current_locus
) == FAILURE
)
2200 vtab
->attr
.target
= 1;
2201 vtab
->attr
.save
= SAVE_IMPLICIT
;
2202 vtab
->attr
.vtab
= 1;
2203 vtab
->attr
.access
= ACCESS_PUBLIC
;
2204 gfc_set_sym_referenced (vtab
);
2205 sprintf (name
, "__vtype_%s", tname
);
2207 gfc_find_symbol (name
, ns
, 0, &vtype
);
2211 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2213 gfc_get_symbol (name
, ns
, &vtype
);
2214 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2215 NULL
, &gfc_current_locus
) == FAILURE
)
2217 vtype
->attr
.access
= ACCESS_PUBLIC
;
2218 vtype
->attr
.vtype
= 1;
2219 gfc_set_sym_referenced (vtype
);
2221 /* Add component '_hash'. */
2222 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2224 c
->ts
.type
= BT_INTEGER
;
2226 c
->attr
.access
= ACCESS_PRIVATE
;
2227 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2228 NULL
, derived
->hash_value
);
2230 /* Add component '_size'. */
2231 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2233 c
->ts
.type
= BT_INTEGER
;
2235 c
->attr
.access
= ACCESS_PRIVATE
;
2236 /* Remember the derived type in ts.u.derived,
2237 so that the correct initializer can be set later on
2238 (in gfc_conv_structure). */
2239 c
->ts
.u
.derived
= derived
;
2240 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2243 /* Add component _extends. */
2244 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2246 c
->attr
.pointer
= 1;
2247 c
->attr
.access
= ACCESS_PRIVATE
;
2248 if (!derived
->attr
.unlimited_polymorphic
)
2249 parent
= gfc_get_derived_super_type (derived
);
2255 parent_vtab
= gfc_find_derived_vtab (parent
);
2256 c
->ts
.type
= BT_DERIVED
;
2257 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2258 c
->initializer
= gfc_get_expr ();
2259 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2260 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2261 0, &c
->initializer
->symtree
);
2265 c
->ts
.type
= BT_DERIVED
;
2266 c
->ts
.u
.derived
= vtype
;
2267 c
->initializer
= gfc_get_null_expr (NULL
);
2270 if (!derived
->attr
.unlimited_polymorphic
2271 && derived
->components
== NULL
2272 && !derived
->attr
.zero_comp
)
2274 /* At this point an error must have occurred.
2275 Prevent further errors on the vtype components. */
2280 /* Add component _def_init. */
2281 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2283 c
->attr
.pointer
= 1;
2284 c
->attr
.artificial
= 1;
2285 c
->attr
.access
= ACCESS_PRIVATE
;
2286 c
->ts
.type
= BT_DERIVED
;
2287 c
->ts
.u
.derived
= derived
;
2288 if (derived
->attr
.unlimited_polymorphic
2289 || derived
->attr
.abstract
)
2290 c
->initializer
= gfc_get_null_expr (NULL
);
2293 /* Construct default initialization variable. */
2294 sprintf (name
, "__def_init_%s", tname
);
2295 gfc_get_symbol (name
, ns
, &def_init
);
2296 def_init
->attr
.target
= 1;
2297 def_init
->attr
.artificial
= 1;
2298 def_init
->attr
.save
= SAVE_IMPLICIT
;
2299 def_init
->attr
.access
= ACCESS_PUBLIC
;
2300 def_init
->attr
.flavor
= FL_VARIABLE
;
2301 gfc_set_sym_referenced (def_init
);
2302 def_init
->ts
.type
= BT_DERIVED
;
2303 def_init
->ts
.u
.derived
= derived
;
2304 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2306 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2309 /* Add component _copy. */
2310 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2312 c
->attr
.proc_pointer
= 1;
2313 c
->attr
.access
= ACCESS_PRIVATE
;
2314 c
->tb
= XCNEW (gfc_typebound_proc
);
2316 if (derived
->attr
.unlimited_polymorphic
2317 || derived
->attr
.abstract
)
2318 c
->initializer
= gfc_get_null_expr (NULL
);
2321 /* Set up namespace. */
2322 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2323 sub_ns
->sibling
= ns
->contained
;
2324 ns
->contained
= sub_ns
;
2325 sub_ns
->resolved
= 1;
2326 /* Set up procedure symbol. */
2327 sprintf (name
, "__copy_%s", tname
);
2328 gfc_get_symbol (name
, sub_ns
, ©
);
2329 sub_ns
->proc_name
= copy
;
2330 copy
->attr
.flavor
= FL_PROCEDURE
;
2331 copy
->attr
.subroutine
= 1;
2332 copy
->attr
.pure
= 1;
2333 copy
->attr
.artificial
= 1;
2334 copy
->attr
.if_source
= IFSRC_DECL
;
2335 /* This is elemental so that arrays are automatically
2336 treated correctly by the scalarizer. */
2337 copy
->attr
.elemental
= 1;
2338 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2339 copy
->module
= ns
->proc_name
->name
;
2340 gfc_set_sym_referenced (copy
);
2341 /* Set up formal arguments. */
2342 gfc_get_symbol ("src", sub_ns
, &src
);
2343 src
->ts
.type
= BT_DERIVED
;
2344 src
->ts
.u
.derived
= derived
;
2345 src
->attr
.flavor
= FL_VARIABLE
;
2346 src
->attr
.dummy
= 1;
2347 src
->attr
.artificial
= 1;
2348 src
->attr
.intent
= INTENT_IN
;
2349 gfc_set_sym_referenced (src
);
2350 copy
->formal
= gfc_get_formal_arglist ();
2351 copy
->formal
->sym
= src
;
2352 gfc_get_symbol ("dst", sub_ns
, &dst
);
2353 dst
->ts
.type
= BT_DERIVED
;
2354 dst
->ts
.u
.derived
= derived
;
2355 dst
->attr
.flavor
= FL_VARIABLE
;
2356 dst
->attr
.dummy
= 1;
2357 dst
->attr
.artificial
= 1;
2358 dst
->attr
.intent
= INTENT_OUT
;
2359 gfc_set_sym_referenced (dst
);
2360 copy
->formal
->next
= gfc_get_formal_arglist ();
2361 copy
->formal
->next
->sym
= dst
;
2363 sub_ns
->code
= gfc_get_code ();
2364 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2365 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2366 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2367 /* Set initializer. */
2368 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2369 c
->ts
.interface
= copy
;
2372 /* Add component _final, which contains a procedure pointer to
2373 a wrapper which handles both the freeing of allocatable
2374 components and the calls to finalization subroutines.
2375 Note: The actual wrapper function can only be generated
2376 at resolution time. */
2377 /* FIXME: Enable ABI-breaking "_final" generation. */
2380 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2382 c
->attr
.proc_pointer
= 1;
2383 c
->attr
.access
= ACCESS_PRIVATE
;
2384 c
->tb
= XCNEW (gfc_typebound_proc
);
2386 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2389 /* Add procedure pointers for type-bound procedures. */
2390 if (!derived
->attr
.unlimited_polymorphic
)
2391 add_procs_to_declared_vtab (derived
, vtype
);
2395 vtab
->ts
.u
.derived
= vtype
;
2396 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2403 /* It is unexpected to have some symbols added at resolution or code
2404 generation time. We commit the changes in order to keep a clean state. */
2407 gfc_commit_symbol (vtab
);
2409 gfc_commit_symbol (vtype
);
2411 gfc_commit_symbol (def_init
);
2413 gfc_commit_symbol (copy
);
2415 gfc_commit_symbol (src
);
2417 gfc_commit_symbol (dst
);
2420 gfc_undo_symbols ();
2426 /* Check if a derived type is finalizable. That is the case if it
2427 (1) has a FINAL subroutine or
2428 (2) has a nonpointer nonallocatable component of finalizable type.
2429 If it is finalizable, return an expression containing the
2430 finalization wrapper. */
2433 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2438 /* (1) Check for FINAL subroutines. */
2439 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2442 /* (2) Check for components of finalizable type. */
2443 for (c
= derived
->components
; c
; c
= c
->next
)
2444 if (c
->ts
.type
== BT_DERIVED
2445 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2446 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2452 /* Make sure vtab is generated. */
2453 vtab
= gfc_find_derived_vtab (derived
);
2456 /* Return finalizer expression. */
2457 gfc_component
*final
;
2458 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2459 gcc_assert (strcmp (final
->name
, "_final") == 0);
2460 gcc_assert (final
->initializer
2461 && final
->initializer
->expr_type
!= EXPR_NULL
);
2462 *final_expr
= final
->initializer
;
2468 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2469 need to support unlimited polymorphism. */
2472 gfc_find_intrinsic_vtab (gfc_typespec
*ts
)
2475 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2476 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2479 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2481 gfc_error ("TODO: Deferred character length variable at %C cannot "
2482 "yet be associated with unlimited polymorphic entities");
2486 if (ts
->type
== BT_UNKNOWN
)
2489 /* Sometimes the typespec is passed from a single call. */
2490 if (ts
->type
== BT_DERIVED
)
2491 return gfc_find_derived_vtab (ts
->u
.derived
);
2493 /* Find the top-level namespace. */
2494 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2498 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
2499 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2500 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2504 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2506 if (ts
->type
== BT_CHARACTER
)
2507 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2510 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2512 sprintf (name
, "__vtab_%s", tname
);
2514 /* Look for the vtab symbol in various namespaces. */
2515 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2517 gfc_find_symbol (name
, ns
, 0, &vtab
);
2521 gfc_get_symbol (name
, ns
, &vtab
);
2522 vtab
->ts
.type
= BT_DERIVED
;
2523 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2524 &gfc_current_locus
) == FAILURE
)
2526 vtab
->attr
.target
= 1;
2527 vtab
->attr
.save
= SAVE_IMPLICIT
;
2528 vtab
->attr
.vtab
= 1;
2529 vtab
->attr
.access
= ACCESS_PUBLIC
;
2530 gfc_set_sym_referenced (vtab
);
2531 sprintf (name
, "__vtype_%s", tname
);
2533 gfc_find_symbol (name
, ns
, 0, &vtype
);
2538 gfc_namespace
*sub_ns
;
2539 gfc_namespace
*contained
;
2541 gfc_get_symbol (name
, ns
, &vtype
);
2542 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2543 NULL
, &gfc_current_locus
) == FAILURE
)
2545 vtype
->attr
.access
= ACCESS_PUBLIC
;
2546 vtype
->attr
.vtype
= 1;
2547 gfc_set_sym_referenced (vtype
);
2549 /* Add component '_hash'. */
2550 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2552 c
->ts
.type
= BT_INTEGER
;
2554 c
->attr
.access
= ACCESS_PRIVATE
;
2555 hash
= gfc_intrinsic_hash_value (ts
);
2556 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2559 /* Add component '_size'. */
2560 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2562 c
->ts
.type
= BT_INTEGER
;
2564 c
->attr
.access
= ACCESS_PRIVATE
;
2565 if (ts
->type
== BT_CHARACTER
)
2566 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2567 NULL
, charlen
*ts
->kind
);
2569 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2572 /* Add component _extends. */
2573 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2575 c
->attr
.pointer
= 1;
2576 c
->attr
.access
= ACCESS_PRIVATE
;
2577 c
->ts
.type
= BT_VOID
;
2578 c
->initializer
= gfc_get_null_expr (NULL
);
2580 /* Add component _def_init. */
2581 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2583 c
->attr
.pointer
= 1;
2584 c
->attr
.access
= ACCESS_PRIVATE
;
2585 c
->ts
.type
= BT_VOID
;
2586 c
->initializer
= gfc_get_null_expr (NULL
);
2588 /* Add component _copy. */
2589 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2591 c
->attr
.proc_pointer
= 1;
2592 c
->attr
.access
= ACCESS_PRIVATE
;
2593 c
->tb
= XCNEW (gfc_typebound_proc
);
2596 /* Check to see if copy function already exists. Note
2597 that this is only used for characters of different
2599 contained
= ns
->contained
;
2600 for (; contained
; contained
= contained
->sibling
)
2601 if (contained
->proc_name
2602 && strcmp (name
, contained
->proc_name
->name
) == 0)
2604 copy
= contained
->proc_name
;
2608 /* Set up namespace. */
2609 sub_ns
= gfc_get_namespace (ns
, 0);
2610 sub_ns
->sibling
= ns
->contained
;
2611 ns
->contained
= sub_ns
;
2612 sub_ns
->resolved
= 1;
2613 /* Set up procedure symbol. */
2614 if (ts
->type
!= BT_CHARACTER
)
2615 sprintf (name
, "__copy_%s", tname
);
2617 /* __copy is always the same for characters. */
2618 sprintf (name
, "__copy_character_%d", ts
->kind
);
2619 gfc_get_symbol (name
, sub_ns
, ©
);
2620 sub_ns
->proc_name
= copy
;
2621 copy
->attr
.flavor
= FL_PROCEDURE
;
2622 copy
->attr
.subroutine
= 1;
2623 copy
->attr
.pure
= 1;
2624 copy
->attr
.if_source
= IFSRC_DECL
;
2625 /* This is elemental so that arrays are automatically
2626 treated correctly by the scalarizer. */
2627 copy
->attr
.elemental
= 1;
2628 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2629 copy
->module
= ns
->proc_name
->name
;
2630 gfc_set_sym_referenced (copy
);
2631 /* Set up formal arguments. */
2632 gfc_get_symbol ("src", sub_ns
, &src
);
2633 src
->ts
.type
= ts
->type
;
2634 src
->ts
.kind
= ts
->kind
;
2635 src
->attr
.flavor
= FL_VARIABLE
;
2636 src
->attr
.dummy
= 1;
2637 src
->attr
.intent
= INTENT_IN
;
2638 gfc_set_sym_referenced (src
);
2639 copy
->formal
= gfc_get_formal_arglist ();
2640 copy
->formal
->sym
= src
;
2641 gfc_get_symbol ("dst", sub_ns
, &dst
);
2642 dst
->ts
.type
= ts
->type
;
2643 dst
->ts
.kind
= ts
->kind
;
2644 dst
->attr
.flavor
= FL_VARIABLE
;
2645 dst
->attr
.dummy
= 1;
2646 dst
->attr
.intent
= INTENT_OUT
;
2647 gfc_set_sym_referenced (dst
);
2648 copy
->formal
->next
= gfc_get_formal_arglist ();
2649 copy
->formal
->next
->sym
= dst
;
2651 sub_ns
->code
= gfc_get_code ();
2652 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2653 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2654 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2656 /* Set initializer. */
2657 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2658 c
->ts
.interface
= copy
;
2660 /* Add component _final. */
2661 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2663 c
->attr
.proc_pointer
= 1;
2664 c
->attr
.access
= ACCESS_PRIVATE
;
2665 c
->tb
= XCNEW (gfc_typebound_proc
);
2667 c
->initializer
= gfc_get_null_expr (NULL
);
2669 vtab
->ts
.u
.derived
= vtype
;
2670 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2677 /* It is unexpected to have some symbols added at resolution or code
2678 generation time. We commit the changes in order to keep a clean state. */
2681 gfc_commit_symbol (vtab
);
2683 gfc_commit_symbol (vtype
);
2685 gfc_commit_symbol (def_init
);
2687 gfc_commit_symbol (copy
);
2689 gfc_commit_symbol (src
);
2691 gfc_commit_symbol (dst
);
2694 gfc_undo_symbols ();
2700 /* General worker function to find either a type-bound procedure or a
2701 type-bound user operator. */
2704 find_typebound_proc_uop (gfc_symbol
* derived
, gfc_try
* t
,
2705 const char* name
, bool noaccess
, bool uop
,
2711 /* Set correct symbol-root. */
2712 gcc_assert (derived
->f2k_derived
);
2713 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2714 : derived
->f2k_derived
->tb_sym_root
);
2716 /* Set default to failure. */
2720 /* Try to find it in the current type's namespace. */
2721 res
= gfc_find_symtree (root
, name
);
2722 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2728 if (!noaccess
&& derived
->attr
.use_assoc
2729 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2732 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2733 name
, derived
->name
, where
);
2741 /* Otherwise, recurse on parent type if derived is an extension. */
2742 if (derived
->attr
.extension
)
2744 gfc_symbol
* super_type
;
2745 super_type
= gfc_get_derived_super_type (derived
);
2746 gcc_assert (super_type
);
2748 return find_typebound_proc_uop (super_type
, t
, name
,
2749 noaccess
, uop
, where
);
2752 /* Nothing found. */
2757 /* Find a type-bound procedure or user operator by name for a derived-type
2758 (looking recursively through the super-types). */
2761 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
2762 const char* name
, bool noaccess
, locus
* where
)
2764 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2768 gfc_find_typebound_user_op (gfc_symbol
* derived
, gfc_try
* t
,
2769 const char* name
, bool noaccess
, locus
* where
)
2771 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2775 /* Find a type-bound intrinsic operator looking recursively through the
2776 super-type hierarchy. */
2779 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_try
* t
,
2780 gfc_intrinsic_op op
, bool noaccess
,
2783 gfc_typebound_proc
* res
;
2785 /* Set default to failure. */
2789 /* Try to find it in the current type's namespace. */
2790 if (derived
->f2k_derived
)
2791 res
= derived
->f2k_derived
->tb_op
[op
];
2796 if (res
&& !res
->error
)
2802 if (!noaccess
&& derived
->attr
.use_assoc
2803 && res
->access
== ACCESS_PRIVATE
)
2806 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2807 gfc_op2string (op
), derived
->name
, where
);
2815 /* Otherwise, recurse on parent type if derived is an extension. */
2816 if (derived
->attr
.extension
)
2818 gfc_symbol
* super_type
;
2819 super_type
= gfc_get_derived_super_type (derived
);
2820 gcc_assert (super_type
);
2822 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2826 /* Nothing found. */
2831 /* Get a typebound-procedure symtree or create and insert it if not yet
2832 present. This is like a very simplified version of gfc_get_sym_tree for
2833 tbp-symtrees rather than regular ones. */
2836 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2838 gfc_symtree
*result
;
2840 result
= gfc_find_symtree (*root
, name
);
2843 result
= gfc_new_symtree (root
, name
);
2844 gcc_assert (result
);
2845 result
->n
.tb
= NULL
;