1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2013 Free Software Foundation, Inc.
3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 and Janus Weil <janus@gcc.gnu.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* class.c -- This file contains the front end functions needed to service
24 the implementation of Fortran 2003 polymorphism and other
25 object-oriented features. */
28 /* Outline of the internal representation:
30 Each CLASS variable is encapsulated by a class container, which is a
31 structure with two fields:
32 * _data: A pointer to the actual data of the variable. This field has the
33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...).
35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
37 For each derived type we set up a "vtable" entry, i.e. a structure with the
39 * _hash: A hash value serving as a unique identifier for this type.
40 * _size: The size in bytes of the derived type.
41 * _extends: A pointer to the vtable entry of the parent derived type.
42 * _def_init: A pointer to a default initialized variable of this type.
43 * _copy: A procedure pointer to a copying procedure.
44 * _final: A procedure pointer to a wrapper function, which frees
45 allocatable components and calls FINAL subroutines.
47 After these follow procedure pointer components for the specific
48 type-bound procedures. */
53 #include "coretypes.h"
55 #include "constructor.h"
57 /* Inserts a derived type component reference in a data reference chain.
58 TS: base type of the ref chain so far, in which we will pick the component
59 REF: the address of the GFC_REF pointer to update
60 NAME: name of the component to insert
61 Note that component insertion makes sense only if we are at the end of
62 the chain (*REF == NULL) or if we are adding a missing "_data" component
63 to access the actual contents of a class object. */
66 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
71 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
72 type_sym
= ts
->u
.derived
;
74 new_ref
= gfc_get_ref ();
75 new_ref
->type
= REF_COMPONENT
;
77 new_ref
->u
.c
.sym
= type_sym
;
78 new_ref
->u
.c
.component
= gfc_find_component (type_sym
, name
, true, true);
79 gcc_assert (new_ref
->u
.c
.component
);
85 /* We need to update the base type in the trailing reference chain to
86 that of the new component. */
88 gcc_assert (strcmp (name
, "_data") == 0);
90 if (new_ref
->next
->type
== REF_COMPONENT
)
92 else if (new_ref
->next
->type
== REF_ARRAY
93 && new_ref
->next
->next
94 && new_ref
->next
->next
->type
== REF_COMPONENT
)
95 next
= new_ref
->next
->next
;
99 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
100 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
101 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
109 /* Tells whether we need to add a "_data" reference to access REF subobject
110 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
111 object accessed by REF is a variable; in other words it is a full object,
115 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
117 /* Only class containers may need the "_data" reference. */
118 if (ts
->type
!= BT_CLASS
)
121 /* Accessing a class container with an array reference is certainly wrong. */
122 if (ref
->type
!= REF_COMPONENT
)
125 /* Accessing the class container's fields is fine. */
126 if (ref
->u
.c
.component
->name
[0] == '_')
129 /* At this point we have a class container with a non class container's field
130 component reference. We don't want to add the "_data" component if we are
131 at the first reference and the symbol's type is an extended derived type.
132 In that case, conv_parent_component_references will do the right thing so
133 it is not absolutely necessary. Omitting it prevents a regression (see
134 class_41.f03) in the interface mapping mechanism. When evaluating string
135 lengths depending on dummy arguments, we create a fake symbol with a type
136 equal to that of the dummy type. However, because of type extension,
137 the backend type (corresponding to the actual argument) can have a
138 different (extended) type. Adding the "_data" component explicitly, using
139 the base type, confuses the gfc_conv_component_ref code which deals with
140 the extended type. */
141 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
144 /* We have a class container with a non class container's field component
145 reference that doesn't fall into the above. */
150 /* Browse through a data reference chain and add the missing "_data" references
151 when a subobject of a class object is accessed without it.
152 Note that it doesn't add the "_data" reference when the class container
153 is the last element in the reference chain. */
156 gfc_fix_class_refs (gfc_expr
*e
)
161 if ((e
->expr_type
!= EXPR_VARIABLE
162 && e
->expr_type
!= EXPR_FUNCTION
)
163 || (e
->expr_type
== EXPR_FUNCTION
164 && e
->value
.function
.isym
!= NULL
))
167 if (e
->expr_type
== EXPR_VARIABLE
)
168 ts
= &e
->symtree
->n
.sym
->ts
;
173 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
174 if (e
->value
.function
.esym
!= NULL
)
175 func
= e
->value
.function
.esym
;
177 func
= e
->symtree
->n
.sym
;
179 if (func
->result
!= NULL
)
180 ts
= &func
->result
->ts
;
185 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
187 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
188 insert_component_ref (ts
, ref
, "_data");
190 if ((*ref
)->type
== REF_COMPONENT
)
191 ts
= &(*ref
)->u
.c
.component
->ts
;
196 /* Insert a reference to the component of the given name.
197 Only to be used with CLASS containers and vtables. */
200 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
202 gfc_ref
**tail
= &(e
->ref
);
203 gfc_ref
*next
= NULL
;
204 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
205 while (*tail
!= NULL
)
207 if ((*tail
)->type
== REF_COMPONENT
)
209 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
211 && (*tail
)->next
->type
== REF_ARRAY
212 && (*tail
)->next
->next
== NULL
)
214 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
216 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
218 tail
= &((*tail
)->next
);
220 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
222 (*tail
) = gfc_get_ref();
223 (*tail
)->next
= next
;
224 (*tail
)->type
= REF_COMPONENT
;
225 (*tail
)->u
.c
.sym
= derived
;
226 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
227 gcc_assert((*tail
)->u
.c
.component
);
229 e
->ts
= (*tail
)->u
.c
.component
->ts
;
233 /* This is used to add both the _data component reference and an array
234 reference to class expressions. Used in translation of intrinsic
235 array inquiry functions. */
238 gfc_add_class_array_ref (gfc_expr
*e
)
240 int rank
= CLASS_DATA (e
)->as
->rank
;
241 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
243 gfc_add_component_ref (e
, "_data");
245 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
248 if (ref
->type
!= REF_ARRAY
)
250 ref
->next
= gfc_get_ref ();
252 ref
->type
= REF_ARRAY
;
253 ref
->u
.ar
.type
= AR_FULL
;
259 /* Unfortunately, class array expressions can appear in various conditions;
260 with and without both _data component and an arrayspec. This function
261 deals with that variability. The previous reference to 'ref' is to a
265 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
267 bool no_data
= false;
268 bool with_data
= false;
270 /* An array reference with no _data component. */
271 if (ref
&& ref
->type
== REF_ARRAY
273 && ref
->u
.ar
.type
!= AR_ELEMENT
)
276 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
280 /* Cover cases where _data appears, with or without an array ref. */
281 if (ref
&& ref
->type
== REF_COMPONENT
282 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
290 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
292 && ref
->type
== REF_COMPONENT
293 && ref
->next
->type
== REF_ARRAY
294 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
298 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
302 return no_data
|| with_data
;
306 /* Returns true if the expression contains a reference to a class
307 array. Notice that class array elements return false. */
310 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
320 /* Is this a class array object? ie. Is the symbol of type class? */
322 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
323 && CLASS_DATA (e
->symtree
->n
.sym
)
324 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
325 && class_array_ref_detected (e
->ref
, full_array
))
328 /* Or is this a class array component reference? */
329 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
331 if (ref
->type
== REF_COMPONENT
332 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
333 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
334 && class_array_ref_detected (ref
->next
, full_array
))
342 /* Returns true if the expression is a reference to a class
343 scalar. This function is necessary because such expressions
344 can be dressed with a reference to the _data component and so
345 have a type other than BT_CLASS. */
348 gfc_is_class_scalar_expr (gfc_expr
*e
)
355 /* Is this a class object? */
357 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
358 && CLASS_DATA (e
->symtree
->n
.sym
)
359 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
361 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
362 && e
->ref
->next
== NULL
)))
365 /* Or is the final reference BT_CLASS or _data? */
366 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
370 && CLASS_DATA (ref
->u
.c
.component
)
371 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
372 && (ref
->next
== NULL
373 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
374 && ref
->next
->next
== NULL
)))
382 /* Tells whether the expression E is a reference to a (scalar) class container.
383 Scalar because array class containers usually have an array reference after
384 them, and gfc_fix_class_refs will add the missing "_data" component reference
388 gfc_is_class_container_ref (gfc_expr
*e
)
393 if (e
->expr_type
!= EXPR_VARIABLE
)
394 return e
->ts
.type
== BT_CLASS
;
396 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
401 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
403 if (ref
->type
!= REF_COMPONENT
)
405 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
415 /* Build a NULL initializer for CLASS pointers,
416 initializing the _data component to NULL and
417 the _vptr component to the declared type. */
420 gfc_class_null_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
424 gfc_symbol
*vtab
= NULL
;
425 bool is_unlimited_polymorphic
;
427 is_unlimited_polymorphic
= ts
->u
.derived
428 && ts
->u
.derived
->components
->ts
.u
.derived
429 && ts
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
;
431 if (is_unlimited_polymorphic
&& init_expr
)
432 vtab
= gfc_find_intrinsic_vtab (&ts
->u
.derived
->components
->ts
);
434 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
436 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
437 &ts
->u
.derived
->declared_at
);
440 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
442 gfc_constructor
*ctor
= gfc_constructor_get();
443 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
444 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
446 ctor
->expr
= gfc_get_null_expr (NULL
);
447 gfc_constructor_append (&init
->value
.constructor
, ctor
);
454 /* Create a unique string identifier for a derived type, composed of its name
455 and module name. This is used to construct unique names for the class
456 containers and vtab symbols. */
459 get_unique_type_string (char *string
, gfc_symbol
*derived
)
461 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
462 if (derived
->attr
.unlimited_polymorphic
)
463 strcpy (dt_name
, "STAR");
465 strcpy (dt_name
, derived
->name
);
466 dt_name
[0] = TOUPPER (dt_name
[0]);
467 if (derived
->attr
.unlimited_polymorphic
)
468 sprintf (string
, "_%s", dt_name
);
469 else if (derived
->module
)
470 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
471 else if (derived
->ns
->proc_name
)
472 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
474 sprintf (string
, "_%s", dt_name
);
478 /* A relative of 'get_unique_type_string' which makes sure the generated
479 string will not be too long (replacing it by a hash string if needed). */
482 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
484 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
485 get_unique_type_string (&tmp
[0], derived
);
486 /* If string is too long, use hash value in hex representation (allow for
487 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
488 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
489 where %d is the (co)rank which can be up to n = 15. */
490 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
492 int h
= gfc_hash_value (derived
);
493 sprintf (string
, "%X", h
);
496 strcpy (string
, tmp
);
500 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
503 gfc_hash_value (gfc_symbol
*sym
)
505 unsigned int hash
= 0;
506 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
509 get_unique_type_string (&c
[0], sym
);
512 for (i
= 0; i
< len
; i
++)
513 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
515 /* Return the hash but take the modulus for the sake of module read,
516 even though this slightly increases the chance of collision. */
517 return (hash
% 100000000);
521 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
524 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
526 unsigned int hash
= 0;
527 const char *c
= gfc_typename (ts
);
532 for (i
= 0; i
< len
; i
++)
533 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
535 /* Return the hash but take the modulus for the sake of module read,
536 even though this slightly increases the chance of collision. */
537 return (hash
% 100000000);
541 /* Build a polymorphic CLASS entity, using the symbol that comes from
542 build_sym. A CLASS entity is represented by an encapsulating type,
543 which contains the declared type as '_data' component, plus a pointer
544 component '_vptr' which determines the dynamic type. */
547 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
548 gfc_array_spec
**as
, bool delayed_vtab
)
550 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
559 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
561 gfc_error ("Assumed size polymorphic objects or components, such "
562 "as that at %C, have not yet been implemented");
567 /* Class container has already been built. */
570 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
571 || attr
->select_type_temporary
|| attr
->associate_var
;
574 /* We can not build the class container yet. */
577 /* Determine the name of the encapsulating type. */
578 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
579 get_unique_hashed_string (tname
, ts
->u
.derived
);
580 if ((*as
) && attr
->allocatable
)
581 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
582 else if ((*as
) && attr
->pointer
)
583 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
585 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
586 else if (attr
->pointer
)
587 sprintf (name
, "__class_%s_p", tname
);
588 else if (attr
->allocatable
)
589 sprintf (name
, "__class_%s_a", tname
);
591 sprintf (name
, "__class_%s", tname
);
593 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
595 /* Find the top-level namespace. */
596 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
601 ns
= ts
->u
.derived
->ns
;
603 gfc_find_symbol (name
, ns
, 0, &fclass
);
607 /* If not there, create a new symbol. */
608 fclass
= gfc_new_symbol (name
, ns
);
609 st
= gfc_new_symtree (&ns
->sym_root
, name
);
611 gfc_set_sym_referenced (fclass
);
613 fclass
->ts
.type
= BT_UNKNOWN
;
614 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
615 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
616 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
617 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
621 /* Add component '_data'. */
622 if (!gfc_add_component (fclass
, "_data", &c
))
625 c
->ts
.type
= BT_DERIVED
;
626 c
->attr
.access
= ACCESS_PRIVATE
;
627 c
->ts
.u
.derived
= ts
->u
.derived
;
628 c
->attr
.class_pointer
= attr
->pointer
;
629 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
630 || attr
->select_type_temporary
;
631 c
->attr
.allocatable
= attr
->allocatable
;
632 c
->attr
.dimension
= attr
->dimension
;
633 c
->attr
.codimension
= attr
->codimension
;
634 c
->attr
.abstract
= fclass
->attr
.abstract
;
636 c
->initializer
= NULL
;
638 /* Add component '_vptr'. */
639 if (!gfc_add_component (fclass
, "_vptr", &c
))
641 c
->ts
.type
= BT_DERIVED
;
643 || (ts
->u
.derived
->f2k_derived
644 && ts
->u
.derived
->f2k_derived
->finalizers
))
645 c
->ts
.u
.derived
= NULL
;
648 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
650 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
652 c
->attr
.access
= ACCESS_PRIVATE
;
656 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
658 /* Since the extension field is 8 bit wide, we can only have
659 up to 255 extension levels. */
660 if (ts
->u
.derived
->attr
.extension
== 255)
662 gfc_error ("Maximum extension level reached with type '%s' at %L",
663 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
667 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
668 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
669 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_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
))
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
|| comp
->attr
.codimension
837 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
838 && (CLASS_DATA (comp
)->attr
.dimension
839 || CLASS_DATA (comp
)->attr
.codimension
)))
841 ref
->next
= gfc_get_ref ();
842 ref
->next
->type
= REF_ARRAY
;
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
;
847 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
850 /* Call DEALLOCATE (comp, stat=ignore). */
851 if (comp
->attr
.allocatable
852 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
853 && CLASS_DATA (comp
)->attr
.allocatable
))
855 gfc_code
*dealloc
, *block
= NULL
;
857 /* Add IF (fini_coarray). */
858 if (comp
->attr
.codimension
859 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
860 && CLASS_DATA (comp
)->attr
.allocatable
))
862 block
= XCNEW (gfc_code
);
865 (*code
)->next
= block
;
866 (*code
) = (*code
)->next
;
871 block
->loc
= gfc_current_locus
;
874 block
->block
= XCNEW (gfc_code
);
875 block
= block
->block
;
876 block
->loc
= gfc_current_locus
;
878 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
881 dealloc
= XCNEW (gfc_code
);
882 dealloc
->op
= EXEC_DEALLOCATE
;
883 dealloc
->loc
= gfc_current_locus
;
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
= XCNEW (gfc_code
);
915 final_wrap
->op
= EXEC_CALL
;
916 final_wrap
->loc
= gfc_current_locus
;
917 final_wrap
->loc
= gfc_current_locus
;
918 final_wrap
->symtree
= c
->initializer
->symtree
;
919 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
920 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
921 final_wrap
->ext
.actual
->expr
= e
;
925 (*code
)->next
= final_wrap
;
926 (*code
) = (*code
)->next
;
929 (*code
) = final_wrap
;
935 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
936 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
942 /* Generate code equivalent to
943 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
944 + offset, c_ptr), ptr). */
947 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
948 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
951 gfc_expr
*expr
, *expr2
;
954 block
= XCNEW (gfc_code
);
955 block
->op
= EXEC_CALL
;
956 block
->loc
= gfc_current_locus
;
957 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
958 block
->resolved_sym
= block
->symtree
->n
.sym
;
959 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
960 block
->resolved_sym
->attr
.intrinsic
= 1;
961 block
->resolved_sym
->attr
.subroutine
= 1;
962 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
963 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
964 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
965 gfc_commit_symbol (block
->resolved_sym
);
967 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
968 block
->ext
.actual
= gfc_get_actual_arglist ();
969 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
970 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
972 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
974 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
976 /* TRANSFER's first argument: C_LOC (array). */
977 expr
= gfc_get_expr ();
978 expr
->expr_type
= EXPR_FUNCTION
;
979 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
980 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
981 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
982 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
983 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
984 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
985 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
986 expr
->value
.function
.actual
->expr
987 = gfc_lval_expr_from_sym (array
);
988 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
989 gfc_commit_symbol (expr
->symtree
->n
.sym
);
990 expr
->ts
.type
= BT_INTEGER
;
991 expr
->ts
.kind
= gfc_index_integer_kind
;
994 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
995 gfc_current_locus
, 3, expr
,
996 gfc_get_int_expr (gfc_index_integer_kind
,
998 expr2
->ts
.type
= BT_INTEGER
;
999 expr2
->ts
.kind
= gfc_index_integer_kind
;
1001 /* <array addr> + <offset>. */
1002 block
->ext
.actual
->expr
= gfc_get_expr ();
1003 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1004 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1005 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1006 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1007 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1009 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1010 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1011 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1012 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1018 /* Calculates the offset to the (idx+1)th element of an array, taking the
1019 stride into account. It generates the code:
1022 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1024 offset = offset * byte_stride. */
1027 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1028 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1029 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1030 gfc_code
*block
, gfc_namespace
*sub_ns
)
1033 gfc_expr
*expr
, *expr2
;
1036 block
->next
= XCNEW (gfc_code
);
1037 block
= block
->next
;
1038 block
->op
= EXEC_ASSIGN
;
1039 block
->loc
= gfc_current_locus
;
1040 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1041 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1044 iter
= gfc_get_iterator ();
1045 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1046 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1047 iter
->end
= gfc_copy_expr (rank
);
1048 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1049 block
->next
= XCNEW (gfc_code
);
1050 block
= block
->next
;
1051 block
->op
= EXEC_DO
;
1052 block
->loc
= gfc_current_locus
;
1053 block
->ext
.iterator
= iter
;
1054 block
->block
= gfc_get_code ();
1055 block
->block
->op
= EXEC_DO
;
1057 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1060 /* mod (idx, sizes(idx2)). */
1061 expr
= gfc_lval_expr_from_sym (sizes
);
1062 expr
->ref
= gfc_get_ref ();
1063 expr
->ref
->type
= REF_ARRAY
;
1064 expr
->ref
->u
.ar
.as
= sizes
->as
;
1065 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1066 expr
->ref
->u
.ar
.dimen
= 1;
1067 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1068 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1070 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1071 gfc_current_locus
, 2,
1072 gfc_lval_expr_from_sym (idx
), expr
);
1075 /* (...) / sizes(idx2-1). */
1076 expr2
= gfc_get_expr ();
1077 expr2
->expr_type
= EXPR_OP
;
1078 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1079 expr2
->value
.op
.op1
= expr
;
1080 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1081 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1082 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1083 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1084 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1085 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1086 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1087 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1088 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1089 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1090 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1091 = gfc_lval_expr_from_sym (idx2
);
1092 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1093 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1094 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1095 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1096 expr2
->ts
= idx
->ts
;
1098 /* ... * strides(idx2). */
1099 expr
= gfc_get_expr ();
1100 expr
->expr_type
= EXPR_OP
;
1101 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1102 expr
->value
.op
.op1
= expr2
;
1103 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1104 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1105 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1106 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1107 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1108 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1109 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1110 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1113 /* offset = offset + ... */
1114 block
->block
->next
= XCNEW (gfc_code
);
1115 block
->block
->next
->op
= EXEC_ASSIGN
;
1116 block
->block
->next
->loc
= gfc_current_locus
;
1117 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1118 block
->block
->next
->expr2
= gfc_get_expr ();
1119 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1120 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1121 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1122 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1123 block
->block
->next
->expr2
->ts
= idx
->ts
;
1125 /* After the loop: offset = offset * byte_stride. */
1126 block
->next
= XCNEW (gfc_code
);
1127 block
= block
->next
;
1128 block
->op
= EXEC_ASSIGN
;
1129 block
->loc
= gfc_current_locus
;
1130 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1131 block
->expr2
= gfc_get_expr ();
1132 block
->expr2
->expr_type
= EXPR_OP
;
1133 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1134 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1135 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1136 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1141 /* Insert code of the following form:
1144 integer(c_intptr_t) :: i
1146 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1147 && (is_contiguous || !final_rank3->attr.contiguous
1148 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1149 || 0 == STORAGE_SIZE (array)) then
1150 call final_rank3 (array)
1153 integer(c_intptr_t) :: offset, j
1154 type(t) :: tmp(shape (array))
1156 do i = 0, size (array)-1
1157 offset = obtain_offset(i, strides, sizes, byte_stride)
1158 addr = transfer (c_loc (array), addr) + offset
1159 call c_f_pointer (transfer (addr, cptr), ptr)
1161 addr = transfer (c_loc (tmp), addr)
1162 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1163 call c_f_pointer (transfer (addr, cptr), ptr2)
1166 call final_rank3 (tmp)
1172 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1173 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1174 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1176 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1177 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1178 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1179 gfc_namespace
*sub_ns
)
1181 gfc_symbol
*tmp_array
, *ptr2
;
1182 gfc_expr
*size_expr
, *offset2
, *expr
;
1188 block
->next
= XCNEW (gfc_code
);
1189 block
= block
->next
;
1190 block
->loc
= gfc_current_locus
;
1191 block
->op
= EXEC_IF
;
1193 block
->block
= XCNEW (gfc_code
);
1194 block
= block
->block
;
1195 block
->loc
= gfc_current_locus
;
1196 block
->op
= EXEC_IF
;
1198 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1199 size_expr
= gfc_get_expr ();
1200 size_expr
->where
= gfc_current_locus
;
1201 size_expr
->expr_type
= EXPR_OP
;
1202 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1204 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1205 size_expr
->value
.op
.op1
1206 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1207 "storage_size", gfc_current_locus
, 2,
1208 gfc_lval_expr_from_sym (array
),
1209 gfc_get_int_expr (gfc_index_integer_kind
,
1212 /* NUMERIC_STORAGE_SIZE. */
1213 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1214 gfc_character_storage_size
);
1215 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1216 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1218 /* IF condition: (stride == size_expr
1219 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1221 || 0 == size_expr. */
1222 block
->expr1
= gfc_get_expr ();
1223 block
->expr1
->ts
.type
= BT_LOGICAL
;
1224 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1225 block
->expr1
->expr_type
= EXPR_OP
;
1226 block
->expr1
->where
= gfc_current_locus
;
1228 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1230 /* byte_stride == size_expr */
1231 expr
= gfc_get_expr ();
1232 expr
->ts
.type
= BT_LOGICAL
;
1233 expr
->ts
.kind
= gfc_default_logical_kind
;
1234 expr
->expr_type
= EXPR_OP
;
1235 expr
->where
= gfc_current_locus
;
1236 expr
->value
.op
.op
= INTRINSIC_EQ
;
1238 = gfc_lval_expr_from_sym (byte_stride
);
1239 expr
->value
.op
.op2
= size_expr
;
1241 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1242 add is_contiguous check. */
1244 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1245 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1248 expr2
= gfc_get_expr ();
1249 expr2
->ts
.type
= BT_LOGICAL
;
1250 expr2
->ts
.kind
= gfc_default_logical_kind
;
1251 expr2
->expr_type
= EXPR_OP
;
1252 expr2
->where
= gfc_current_locus
;
1253 expr2
->value
.op
.op
= INTRINSIC_AND
;
1254 expr2
->value
.op
.op1
= expr
;
1255 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1259 block
->expr1
->value
.op
.op1
= expr
;
1261 /* 0 == size_expr */
1262 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1263 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1264 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1265 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1266 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1267 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1268 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1269 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1270 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1272 /* IF body: call final subroutine. */
1273 block
->next
= XCNEW (gfc_code
);
1274 block
->next
->op
= EXEC_CALL
;
1275 block
->next
->loc
= gfc_current_locus
;
1276 block
->next
->symtree
= fini
->proc_tree
;
1277 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1278 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1279 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1283 block
->block
= XCNEW (gfc_code
);
1284 block
= block
->block
;
1285 block
->loc
= gfc_current_locus
;
1286 block
->op
= EXEC_IF
;
1288 block
->next
= XCNEW (gfc_code
);
1289 block
= block
->next
;
1291 /* BLOCK ... END BLOCK. */
1292 block
->op
= EXEC_BLOCK
;
1293 block
->loc
= gfc_current_locus
;
1294 ns
= gfc_build_block_ns (sub_ns
);
1295 block
->ext
.block
.ns
= ns
;
1296 block
->ext
.block
.assoc
= NULL
;
1298 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1299 ptr2
->ts
.type
= BT_DERIVED
;
1300 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1301 ptr2
->attr
.flavor
= FL_VARIABLE
;
1302 ptr2
->attr
.pointer
= 1;
1303 ptr2
->attr
.artificial
= 1;
1304 gfc_set_sym_referenced (ptr2
);
1305 gfc_commit_symbol (ptr2
);
1307 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1308 tmp_array
->ts
.type
= BT_DERIVED
;
1309 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1310 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1311 tmp_array
->attr
.dimension
= 1;
1312 tmp_array
->attr
.artificial
= 1;
1313 tmp_array
->as
= gfc_get_array_spec();
1314 tmp_array
->attr
.intent
= INTENT_INOUT
;
1315 tmp_array
->as
->type
= AS_EXPLICIT
;
1316 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1318 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1320 gfc_expr
*shape_expr
;
1321 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1323 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1325 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1326 gfc_current_locus
, 3,
1327 gfc_lval_expr_from_sym (array
),
1328 gfc_get_int_expr (gfc_default_integer_kind
,
1330 gfc_get_int_expr (gfc_default_integer_kind
,
1332 gfc_index_integer_kind
));
1333 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1334 tmp_array
->as
->upper
[i
] = shape_expr
;
1336 gfc_set_sym_referenced (tmp_array
);
1337 gfc_commit_symbol (tmp_array
);
1340 iter
= gfc_get_iterator ();
1341 iter
->var
= gfc_lval_expr_from_sym (idx
);
1342 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1343 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1344 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1346 block
= XCNEW (gfc_code
);
1348 block
->op
= EXEC_DO
;
1349 block
->loc
= gfc_current_locus
;
1350 block
->ext
.iterator
= iter
;
1351 block
->block
= gfc_get_code ();
1352 block
->block
->op
= EXEC_DO
;
1354 /* Offset calculation for the new array: idx * size of type (in bytes). */
1355 offset2
= gfc_get_expr ();
1356 offset2
->expr_type
= EXPR_OP
;
1357 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1358 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1359 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1360 offset2
->ts
= byte_stride
->ts
;
1362 /* Offset calculation of "array". */
1363 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1364 byte_stride
, rank
, block
->block
, sub_ns
);
1367 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1368 + idx * stride, c_ptr), ptr). */
1369 block2
->next
= finalization_scalarizer (array
, ptr
,
1370 gfc_lval_expr_from_sym (offset
),
1372 block2
= block2
->next
;
1373 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1374 block2
= block2
->next
;
1377 block2
->next
= XCNEW (gfc_code
);
1378 block2
= block2
->next
;
1379 block2
->op
= EXEC_ASSIGN
;
1380 block2
->loc
= gfc_current_locus
;
1381 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1382 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1384 /* Call now the user's final subroutine. */
1385 block
->next
= XCNEW (gfc_code
);
1386 block
= block
->next
;
1387 block
->op
= EXEC_CALL
;
1388 block
->loc
= gfc_current_locus
;
1389 block
->symtree
= fini
->proc_tree
;
1390 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1391 block
->ext
.actual
= gfc_get_actual_arglist ();
1392 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1394 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1400 iter
= gfc_get_iterator ();
1401 iter
->var
= gfc_lval_expr_from_sym (idx
);
1402 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1403 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1404 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1406 block
->next
= XCNEW (gfc_code
);
1407 block
= block
->next
;
1408 block
->op
= EXEC_DO
;
1409 block
->loc
= gfc_current_locus
;
1410 block
->ext
.iterator
= iter
;
1411 block
->block
= gfc_get_code ();
1412 block
->block
->op
= EXEC_DO
;
1414 /* Offset calculation of "array". */
1415 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1416 byte_stride
, rank
, block
->block
, sub_ns
);
1419 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1420 + offset, c_ptr), ptr). */
1421 block2
->next
= finalization_scalarizer (array
, ptr
,
1422 gfc_lval_expr_from_sym (offset
),
1424 block2
= block2
->next
;
1425 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1426 gfc_copy_expr (offset2
), sub_ns
);
1427 block2
= block2
->next
;
1430 block2
->next
= XCNEW (gfc_code
);
1431 block2
->next
->op
= EXEC_ASSIGN
;
1432 block2
->next
->loc
= gfc_current_locus
;
1433 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1434 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1438 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1439 derived type "derived". The function first calls the approriate FINAL
1440 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1441 components (but not the inherited ones). Last, it calls the wrapper
1442 subroutine of the parent. The generated wrapper procedure takes as argument
1443 an assumed-rank array.
1444 If neither allocatable components nor FINAL subroutines exists, the vtab
1445 will contain a NULL pointer.
1446 The generated function has the form
1447 _final(assumed-rank array, stride, skip_corarray)
1448 where the array has to be contiguous (except of the lowest dimension). The
1449 stride (in bytes) is used to allow different sizes for ancestor types by
1450 skipping over the additionally added components in the scalarizer. If
1451 "fini_coarray" is false, coarray components are not finalized to allow for
1452 the correct semantic with intrinsic assignment. */
1455 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1456 const char *tname
, gfc_component
*vtab_final
)
1458 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1459 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1460 gfc_component
*comp
;
1461 gfc_namespace
*sub_ns
;
1462 gfc_code
*last_code
, *block
;
1463 char name
[GFC_MAX_SYMBOL_LEN
+1];
1464 bool finalizable_comp
= false;
1465 bool expr_null_wrapper
= false;
1466 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1469 /* Search for the ancestor's finalizers. */
1470 if (derived
->attr
.extension
&& derived
->components
1471 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1472 || has_finalizer_component (derived
)))
1475 gfc_component
*comp
;
1477 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1478 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1479 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1481 ancestor_wrapper
= comp
->initializer
;
1486 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1487 components: Return a NULL() expression; we defer this a bit to have have
1488 an interface declaration. */
1489 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1490 && !derived
->attr
.alloc_comp
1491 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1492 && !has_finalizer_component (derived
))
1493 expr_null_wrapper
= true;
1495 /* Check whether there are new allocatable components. */
1496 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1498 if (comp
== derived
->components
&& derived
->attr
.extension
1499 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1502 if (comp
->ts
.type
!= BT_CLASS
&& !comp
->attr
.pointer
1503 && (comp
->attr
.allocatable
1504 || (comp
->ts
.type
== BT_DERIVED
1505 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1506 || has_finalizer_component (comp
->ts
.u
.derived
)
1507 || (comp
->ts
.u
.derived
->f2k_derived
1508 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))))
1509 finalizable_comp
= true;
1510 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1511 && CLASS_DATA (comp
)->attr
.allocatable
)
1512 finalizable_comp
= true;
1515 /* If there is no new finalizer and no new allocatable, return with
1516 an expr to the ancestor's one. */
1517 if (!expr_null_wrapper
&& !finalizable_comp
1518 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1520 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1521 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1522 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1523 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1527 /* We now create a wrapper, which does the following:
1528 1. Call the suitable finalization subroutine for this type
1529 2. Loop over all noninherited allocatable components and noninherited
1530 components with allocatable components and DEALLOCATE those; this will
1531 take care of finalizers, coarray deregistering and allocatable
1533 3. Call the ancestor's finalizer. */
1535 /* Declare the wrapper function; it takes an assumed-rank array
1536 and a VALUE logical as arguments. */
1538 /* Set up the namespace. */
1539 sub_ns
= gfc_get_namespace (ns
, 0);
1540 sub_ns
->sibling
= ns
->contained
;
1541 if (!expr_null_wrapper
)
1542 ns
->contained
= sub_ns
;
1543 sub_ns
->resolved
= 1;
1545 /* Set up the procedure symbol. */
1546 sprintf (name
, "__final_%s", tname
);
1547 gfc_get_symbol (name
, sub_ns
, &final
);
1548 sub_ns
->proc_name
= final
;
1549 final
->attr
.flavor
= FL_PROCEDURE
;
1550 final
->attr
.function
= 1;
1551 final
->attr
.pure
= 0;
1552 final
->result
= final
;
1553 final
->ts
.type
= BT_INTEGER
;
1555 final
->attr
.artificial
= 1;
1556 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1557 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1558 final
->module
= ns
->proc_name
->name
;
1559 gfc_set_sym_referenced (final
);
1560 gfc_commit_symbol (final
);
1562 /* Set up formal argument. */
1563 gfc_get_symbol ("array", sub_ns
, &array
);
1564 array
->ts
.type
= BT_DERIVED
;
1565 array
->ts
.u
.derived
= derived
;
1566 array
->attr
.flavor
= FL_VARIABLE
;
1567 array
->attr
.dummy
= 1;
1568 array
->attr
.contiguous
= 1;
1569 array
->attr
.dimension
= 1;
1570 array
->attr
.artificial
= 1;
1571 array
->as
= gfc_get_array_spec();
1572 array
->as
->type
= AS_ASSUMED_RANK
;
1573 array
->as
->rank
= -1;
1574 array
->attr
.intent
= INTENT_INOUT
;
1575 gfc_set_sym_referenced (array
);
1576 final
->formal
= gfc_get_formal_arglist ();
1577 final
->formal
->sym
= array
;
1578 gfc_commit_symbol (array
);
1580 /* Set up formal argument. */
1581 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1582 byte_stride
->ts
.type
= BT_INTEGER
;
1583 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1584 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1585 byte_stride
->attr
.dummy
= 1;
1586 byte_stride
->attr
.value
= 1;
1587 byte_stride
->attr
.artificial
= 1;
1588 gfc_set_sym_referenced (byte_stride
);
1589 final
->formal
->next
= gfc_get_formal_arglist ();
1590 final
->formal
->next
->sym
= byte_stride
;
1591 gfc_commit_symbol (byte_stride
);
1593 /* Set up formal argument. */
1594 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1595 fini_coarray
->ts
.type
= BT_LOGICAL
;
1596 fini_coarray
->ts
.kind
= 1;
1597 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1598 fini_coarray
->attr
.dummy
= 1;
1599 fini_coarray
->attr
.value
= 1;
1600 fini_coarray
->attr
.artificial
= 1;
1601 gfc_set_sym_referenced (fini_coarray
);
1602 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1603 final
->formal
->next
->next
->sym
= fini_coarray
;
1604 gfc_commit_symbol (fini_coarray
);
1606 /* Return with a NULL() expression but with an interface which has
1607 the formal arguments. */
1608 if (expr_null_wrapper
)
1610 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1611 vtab_final
->ts
.interface
= final
;
1615 /* Local variables. */
1617 gfc_get_symbol ("idx", sub_ns
, &idx
);
1618 idx
->ts
.type
= BT_INTEGER
;
1619 idx
->ts
.kind
= gfc_index_integer_kind
;
1620 idx
->attr
.flavor
= FL_VARIABLE
;
1621 idx
->attr
.artificial
= 1;
1622 gfc_set_sym_referenced (idx
);
1623 gfc_commit_symbol (idx
);
1625 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1626 idx2
->ts
.type
= BT_INTEGER
;
1627 idx2
->ts
.kind
= gfc_index_integer_kind
;
1628 idx2
->attr
.flavor
= FL_VARIABLE
;
1629 idx2
->attr
.artificial
= 1;
1630 gfc_set_sym_referenced (idx2
);
1631 gfc_commit_symbol (idx2
);
1633 gfc_get_symbol ("offset", sub_ns
, &offset
);
1634 offset
->ts
.type
= BT_INTEGER
;
1635 offset
->ts
.kind
= gfc_index_integer_kind
;
1636 offset
->attr
.flavor
= FL_VARIABLE
;
1637 offset
->attr
.artificial
= 1;
1638 gfc_set_sym_referenced (offset
);
1639 gfc_commit_symbol (offset
);
1641 /* Create RANK expression. */
1642 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1643 gfc_current_locus
, 1,
1644 gfc_lval_expr_from_sym (array
));
1645 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1646 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1648 /* Create is_contiguous variable. */
1649 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1650 is_contiguous
->ts
.type
= BT_LOGICAL
;
1651 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1652 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1653 is_contiguous
->attr
.artificial
= 1;
1654 gfc_set_sym_referenced (is_contiguous
);
1655 gfc_commit_symbol (is_contiguous
);
1657 /* Create "sizes(0..rank)" variable, which contains the multiplied
1658 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1659 sizes(2) = sizes(1) * extent(dim=2) etc. */
1660 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1661 sizes
->ts
.type
= BT_INTEGER
;
1662 sizes
->ts
.kind
= gfc_index_integer_kind
;
1663 sizes
->attr
.flavor
= FL_VARIABLE
;
1664 sizes
->attr
.dimension
= 1;
1665 sizes
->attr
.artificial
= 1;
1666 sizes
->as
= gfc_get_array_spec();
1667 sizes
->attr
.intent
= INTENT_INOUT
;
1668 sizes
->as
->type
= AS_EXPLICIT
;
1669 sizes
->as
->rank
= 1;
1670 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1671 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1672 gfc_set_sym_referenced (sizes
);
1673 gfc_commit_symbol (sizes
);
1675 /* Create "strides(1..rank)" variable, which contains the strides per
1677 gfc_get_symbol ("strides", sub_ns
, &strides
);
1678 strides
->ts
.type
= BT_INTEGER
;
1679 strides
->ts
.kind
= gfc_index_integer_kind
;
1680 strides
->attr
.flavor
= FL_VARIABLE
;
1681 strides
->attr
.dimension
= 1;
1682 strides
->attr
.artificial
= 1;
1683 strides
->as
= gfc_get_array_spec();
1684 strides
->attr
.intent
= INTENT_INOUT
;
1685 strides
->as
->type
= AS_EXPLICIT
;
1686 strides
->as
->rank
= 1;
1687 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1688 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1689 gfc_set_sym_referenced (strides
);
1690 gfc_commit_symbol (strides
);
1693 /* Set return value to 0. */
1694 last_code
= XCNEW (gfc_code
);
1695 last_code
->op
= EXEC_ASSIGN
;
1696 last_code
->loc
= gfc_current_locus
;
1697 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1698 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1699 sub_ns
->code
= last_code
;
1701 /* Set: is_contiguous = .true. */
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 (is_contiguous
);
1707 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1708 &gfc_current_locus
, true);
1710 /* Set: sizes(0) = 1. */
1711 last_code
->next
= XCNEW (gfc_code
);
1712 last_code
= last_code
->next
;
1713 last_code
->op
= EXEC_ASSIGN
;
1714 last_code
->loc
= gfc_current_locus
;
1715 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1716 last_code
->expr1
->ref
= gfc_get_ref ();
1717 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1718 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1719 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1720 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1721 last_code
->expr1
->ref
->u
.ar
.start
[0]
1722 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1723 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1724 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1728 strides(idx) = _F._stride (array, dim=idx)
1729 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1730 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1734 iter
= gfc_get_iterator ();
1735 iter
->var
= gfc_lval_expr_from_sym (idx
);
1736 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1737 iter
->end
= gfc_copy_expr (rank
);
1738 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1739 last_code
->next
= XCNEW (gfc_code
);
1740 last_code
= last_code
->next
;
1741 last_code
->op
= EXEC_DO
;
1742 last_code
->loc
= gfc_current_locus
;
1743 last_code
->ext
.iterator
= iter
;
1744 last_code
->block
= gfc_get_code ();
1745 last_code
->block
->op
= EXEC_DO
;
1747 /* strides(idx) = _F._stride(array,dim=idx). */
1748 last_code
->block
->next
= XCNEW (gfc_code
);
1749 block
= last_code
->block
->next
;
1750 block
->op
= EXEC_ASSIGN
;
1751 block
->loc
= gfc_current_locus
;
1753 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1754 block
->expr1
->ref
= gfc_get_ref ();
1755 block
->expr1
->ref
->type
= REF_ARRAY
;
1756 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1757 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1758 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1759 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1760 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1762 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1763 gfc_current_locus
, 2,
1764 gfc_lval_expr_from_sym (array
),
1765 gfc_lval_expr_from_sym (idx
));
1767 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1768 block
->next
= XCNEW (gfc_code
);
1769 block
= block
->next
;
1770 block
->op
= EXEC_ASSIGN
;
1771 block
->loc
= gfc_current_locus
;
1773 /* sizes(idx) = ... */
1774 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1775 block
->expr1
->ref
= gfc_get_ref ();
1776 block
->expr1
->ref
->type
= REF_ARRAY
;
1777 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1778 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1779 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1780 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1781 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1783 block
->expr2
= gfc_get_expr ();
1784 block
->expr2
->expr_type
= EXPR_OP
;
1785 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1788 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1789 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1790 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1791 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1792 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1793 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1794 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1795 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1796 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1797 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1798 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1799 = gfc_lval_expr_from_sym (idx
);
1800 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1801 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1802 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1803 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1805 /* size(array, dim=idx, kind=index_kind). */
1806 block
->expr2
->value
.op
.op2
1807 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1808 gfc_current_locus
, 3,
1809 gfc_lval_expr_from_sym (array
),
1810 gfc_lval_expr_from_sym (idx
),
1811 gfc_get_int_expr (gfc_index_integer_kind
,
1813 gfc_index_integer_kind
));
1814 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1815 block
->expr2
->ts
= idx
->ts
;
1817 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1818 block
->next
= XCNEW (gfc_code
);
1819 block
= block
->next
;
1820 block
->loc
= gfc_current_locus
;
1821 block
->op
= EXEC_IF
;
1823 block
->block
= XCNEW (gfc_code
);
1824 block
= block
->block
;
1825 block
->loc
= gfc_current_locus
;
1826 block
->op
= EXEC_IF
;
1828 /* if condition: strides(idx) /= sizes(idx-1). */
1829 block
->expr1
= gfc_get_expr ();
1830 block
->expr1
->ts
.type
= BT_LOGICAL
;
1831 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1832 block
->expr1
->expr_type
= EXPR_OP
;
1833 block
->expr1
->where
= gfc_current_locus
;
1834 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1836 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1837 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1838 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1839 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1840 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1841 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1842 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1843 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1845 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1846 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1847 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1848 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1849 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1850 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1851 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1852 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1853 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1854 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1855 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1856 = gfc_lval_expr_from_sym (idx
);
1857 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1858 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1859 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1860 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1862 /* if body: is_contiguous = .false. */
1863 block
->next
= XCNEW (gfc_code
);
1864 block
= block
->next
;
1865 block
->op
= EXEC_ASSIGN
;
1866 block
->loc
= gfc_current_locus
;
1867 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1868 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1869 &gfc_current_locus
, false);
1871 /* Obtain the size (number of elements) of "array" MINUS ONE,
1872 which is used in the scalarization. */
1873 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1874 nelem
->ts
.type
= BT_INTEGER
;
1875 nelem
->ts
.kind
= gfc_index_integer_kind
;
1876 nelem
->attr
.flavor
= FL_VARIABLE
;
1877 nelem
->attr
.artificial
= 1;
1878 gfc_set_sym_referenced (nelem
);
1879 gfc_commit_symbol (nelem
);
1881 /* nelem = sizes (rank) - 1. */
1882 last_code
->next
= XCNEW (gfc_code
);
1883 last_code
= last_code
->next
;
1884 last_code
->op
= EXEC_ASSIGN
;
1885 last_code
->loc
= gfc_current_locus
;
1887 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1889 last_code
->expr2
= gfc_get_expr ();
1890 last_code
->expr2
->expr_type
= EXPR_OP
;
1891 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1892 last_code
->expr2
->value
.op
.op2
1893 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1894 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1896 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1897 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1898 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1899 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1900 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1901 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1902 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1903 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1905 /* Call final subroutines. We now generate code like:
1907 integer, pointer :: ptr
1909 integer(c_intptr_t) :: i, addr
1911 select case (rank (array))
1913 ! If needed, the array is packed
1914 call final_rank3 (array)
1916 do i = 0, size (array)-1
1917 addr = transfer (c_loc (array), addr) + i * stride
1918 call c_f_pointer (transfer (addr, cptr), ptr)
1919 call elemental_final (ptr)
1923 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1925 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1927 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
1928 ptr
->ts
.type
= BT_DERIVED
;
1929 ptr
->ts
.u
.derived
= derived
;
1930 ptr
->attr
.flavor
= FL_VARIABLE
;
1931 ptr
->attr
.pointer
= 1;
1932 ptr
->attr
.artificial
= 1;
1933 gfc_set_sym_referenced (ptr
);
1934 gfc_commit_symbol (ptr
);
1936 /* SELECT CASE (RANK (array)). */
1937 last_code
->next
= XCNEW (gfc_code
);
1938 last_code
= last_code
->next
;
1939 last_code
->op
= EXEC_SELECT
;
1940 last_code
->loc
= gfc_current_locus
;
1941 last_code
->expr1
= gfc_copy_expr (rank
);
1944 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1946 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1952 /* CASE (fini_rank). */
1955 block
->block
= XCNEW (gfc_code
);
1956 block
= block
->block
;
1960 block
= XCNEW (gfc_code
);
1961 last_code
->block
= block
;
1963 block
->loc
= gfc_current_locus
;
1964 block
->op
= EXEC_SELECT
;
1965 block
->ext
.block
.case_list
= gfc_get_case ();
1966 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1967 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1968 block
->ext
.block
.case_list
->low
1969 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1970 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
1972 block
->ext
.block
.case_list
->low
1973 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1974 block
->ext
.block
.case_list
->high
1975 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
1977 /* CALL fini_rank (array) - possibly with packing. */
1978 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1979 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
1980 idx
, ptr
, nelem
, strides
,
1981 sizes
, idx2
, offset
, is_contiguous
,
1985 block
->next
= XCNEW (gfc_code
);
1986 block
->next
->op
= EXEC_CALL
;
1987 block
->next
->loc
= gfc_current_locus
;
1988 block
->next
->symtree
= fini
->proc_tree
;
1989 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1990 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1991 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1995 /* Elemental call - scalarized. */
2001 block
->block
= XCNEW (gfc_code
);
2002 block
= block
->block
;
2006 block
= XCNEW (gfc_code
);
2007 last_code
->block
= block
;
2009 block
->loc
= gfc_current_locus
;
2010 block
->op
= EXEC_SELECT
;
2011 block
->ext
.block
.case_list
= gfc_get_case ();
2014 iter
= gfc_get_iterator ();
2015 iter
->var
= gfc_lval_expr_from_sym (idx
);
2016 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2017 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2018 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2019 block
->next
= XCNEW (gfc_code
);
2020 block
= block
->next
;
2021 block
->op
= EXEC_DO
;
2022 block
->loc
= gfc_current_locus
;
2023 block
->ext
.iterator
= iter
;
2024 block
->block
= gfc_get_code ();
2025 block
->block
->op
= EXEC_DO
;
2027 /* Offset calculation. */
2028 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2029 byte_stride
, rank
, block
->block
,
2033 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2034 + offset, c_ptr), ptr). */
2036 = finalization_scalarizer (array
, ptr
,
2037 gfc_lval_expr_from_sym (offset
),
2039 block
= block
->next
;
2041 /* CALL final_elemental (array). */
2042 block
->next
= XCNEW (gfc_code
);
2043 block
= block
->next
;
2044 block
->op
= EXEC_CALL
;
2045 block
->loc
= gfc_current_locus
;
2046 block
->symtree
= fini_elem
->proc_tree
;
2047 block
->resolved_sym
= fini_elem
->proc_sym
;
2048 block
->ext
.actual
= gfc_get_actual_arglist ();
2049 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2053 /* Finalize and deallocate allocatable components. The same manual
2054 scalarization is used as above. */
2056 if (finalizable_comp
)
2059 gfc_code
*block
= NULL
;
2063 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2064 ptr
->ts
.type
= BT_DERIVED
;
2065 ptr
->ts
.u
.derived
= derived
;
2066 ptr
->attr
.flavor
= FL_VARIABLE
;
2067 ptr
->attr
.pointer
= 1;
2068 ptr
->attr
.artificial
= 1;
2069 gfc_set_sym_referenced (ptr
);
2070 gfc_commit_symbol (ptr
);
2073 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2074 stat
->attr
.flavor
= FL_VARIABLE
;
2075 stat
->attr
.artificial
= 1;
2076 stat
->ts
.type
= BT_INTEGER
;
2077 stat
->ts
.kind
= gfc_default_integer_kind
;
2078 gfc_set_sym_referenced (stat
);
2079 gfc_commit_symbol (stat
);
2082 iter
= gfc_get_iterator ();
2083 iter
->var
= gfc_lval_expr_from_sym (idx
);
2084 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2085 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2086 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2087 last_code
->next
= XCNEW (gfc_code
);
2088 last_code
= last_code
->next
;
2089 last_code
->op
= EXEC_DO
;
2090 last_code
->loc
= gfc_current_locus
;
2091 last_code
->ext
.iterator
= iter
;
2092 last_code
->block
= gfc_get_code ();
2093 last_code
->block
->op
= EXEC_DO
;
2095 /* Offset calculation. */
2096 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2097 byte_stride
, rank
, last_code
->block
,
2101 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2102 + idx * stride, c_ptr), ptr). */
2103 block
->next
= finalization_scalarizer (array
, ptr
,
2104 gfc_lval_expr_from_sym(offset
),
2106 block
= block
->next
;
2108 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2110 if (comp
== derived
->components
&& derived
->attr
.extension
2111 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2114 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2115 stat
, fini_coarray
, &block
);
2116 if (!last_code
->block
->next
)
2117 last_code
->block
->next
= block
;
2122 /* Call the finalizer of the ancestor. */
2123 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2125 last_code
->next
= XCNEW (gfc_code
);
2126 last_code
= last_code
->next
;
2127 last_code
->op
= EXEC_CALL
;
2128 last_code
->loc
= gfc_current_locus
;
2129 last_code
->symtree
= ancestor_wrapper
->symtree
;
2130 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2132 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2133 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2134 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2135 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2136 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2137 last_code
->ext
.actual
->next
->next
->expr
2138 = gfc_lval_expr_from_sym (fini_coarray
);
2141 gfc_free_expr (rank
);
2142 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2143 vtab_final
->ts
.interface
= final
;
2147 /* Add procedure pointers for all type-bound procedures to a vtab. */
2150 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2152 gfc_symbol
* super_type
;
2154 super_type
= gfc_get_derived_super_type (derived
);
2156 if (super_type
&& (super_type
!= derived
))
2158 /* Make sure that the PPCs appear in the same order as in the parent. */
2159 copy_vtab_proc_comps (super_type
, vtype
);
2160 /* Only needed to get the PPC initializers right. */
2161 add_procs_to_declared_vtab (super_type
, vtype
);
2164 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2165 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2167 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2168 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2172 /* Find or generate the symbol for a derived type's vtab. */
2175 gfc_find_derived_vtab (gfc_symbol
*derived
)
2178 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2179 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2181 /* Find the top-level namespace. */
2182 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2186 /* If the type is a class container, use the underlying derived type. */
2187 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2188 derived
= gfc_get_derived_super_type (derived
);
2192 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2194 get_unique_hashed_string (tname
, derived
);
2195 sprintf (name
, "__vtab_%s", tname
);
2197 /* Look for the vtab symbol in various namespaces. */
2198 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2200 gfc_find_symbol (name
, ns
, 0, &vtab
);
2202 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2206 gfc_get_symbol (name
, ns
, &vtab
);
2207 vtab
->ts
.type
= BT_DERIVED
;
2208 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2209 &gfc_current_locus
))
2211 vtab
->attr
.target
= 1;
2212 vtab
->attr
.save
= SAVE_IMPLICIT
;
2213 vtab
->attr
.vtab
= 1;
2214 vtab
->attr
.access
= ACCESS_PUBLIC
;
2215 gfc_set_sym_referenced (vtab
);
2216 sprintf (name
, "__vtype_%s", tname
);
2218 gfc_find_symbol (name
, ns
, 0, &vtype
);
2222 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2224 gfc_get_symbol (name
, ns
, &vtype
);
2225 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2226 &gfc_current_locus
))
2228 vtype
->attr
.access
= ACCESS_PUBLIC
;
2229 vtype
->attr
.vtype
= 1;
2230 gfc_set_sym_referenced (vtype
);
2232 /* Add component '_hash'. */
2233 if (!gfc_add_component (vtype
, "_hash", &c
))
2235 c
->ts
.type
= BT_INTEGER
;
2237 c
->attr
.access
= ACCESS_PRIVATE
;
2238 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2239 NULL
, derived
->hash_value
);
2241 /* Add component '_size'. */
2242 if (!gfc_add_component (vtype
, "_size", &c
))
2244 c
->ts
.type
= BT_INTEGER
;
2246 c
->attr
.access
= ACCESS_PRIVATE
;
2247 /* Remember the derived type in ts.u.derived,
2248 so that the correct initializer can be set later on
2249 (in gfc_conv_structure). */
2250 c
->ts
.u
.derived
= derived
;
2251 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2254 /* Add component _extends. */
2255 if (!gfc_add_component (vtype
, "_extends", &c
))
2257 c
->attr
.pointer
= 1;
2258 c
->attr
.access
= ACCESS_PRIVATE
;
2259 if (!derived
->attr
.unlimited_polymorphic
)
2260 parent
= gfc_get_derived_super_type (derived
);
2266 parent_vtab
= gfc_find_derived_vtab (parent
);
2267 c
->ts
.type
= BT_DERIVED
;
2268 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2269 c
->initializer
= gfc_get_expr ();
2270 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2271 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2272 0, &c
->initializer
->symtree
);
2276 c
->ts
.type
= BT_DERIVED
;
2277 c
->ts
.u
.derived
= vtype
;
2278 c
->initializer
= gfc_get_null_expr (NULL
);
2281 if (!derived
->attr
.unlimited_polymorphic
2282 && derived
->components
== NULL
2283 && !derived
->attr
.zero_comp
)
2285 /* At this point an error must have occurred.
2286 Prevent further errors on the vtype components. */
2291 /* Add component _def_init. */
2292 if (!gfc_add_component (vtype
, "_def_init", &c
))
2294 c
->attr
.pointer
= 1;
2295 c
->attr
.artificial
= 1;
2296 c
->attr
.access
= ACCESS_PRIVATE
;
2297 c
->ts
.type
= BT_DERIVED
;
2298 c
->ts
.u
.derived
= derived
;
2299 if (derived
->attr
.unlimited_polymorphic
2300 || derived
->attr
.abstract
)
2301 c
->initializer
= gfc_get_null_expr (NULL
);
2304 /* Construct default initialization variable. */
2305 sprintf (name
, "__def_init_%s", tname
);
2306 gfc_get_symbol (name
, ns
, &def_init
);
2307 def_init
->attr
.target
= 1;
2308 def_init
->attr
.artificial
= 1;
2309 def_init
->attr
.save
= SAVE_IMPLICIT
;
2310 def_init
->attr
.access
= ACCESS_PUBLIC
;
2311 def_init
->attr
.flavor
= FL_VARIABLE
;
2312 gfc_set_sym_referenced (def_init
);
2313 def_init
->ts
.type
= BT_DERIVED
;
2314 def_init
->ts
.u
.derived
= derived
;
2315 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2317 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2320 /* Add component _copy. */
2321 if (!gfc_add_component (vtype
, "_copy", &c
))
2323 c
->attr
.proc_pointer
= 1;
2324 c
->attr
.access
= ACCESS_PRIVATE
;
2325 c
->tb
= XCNEW (gfc_typebound_proc
);
2327 if (derived
->attr
.unlimited_polymorphic
2328 || derived
->attr
.abstract
)
2329 c
->initializer
= gfc_get_null_expr (NULL
);
2332 /* Set up namespace. */
2333 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2334 sub_ns
->sibling
= ns
->contained
;
2335 ns
->contained
= sub_ns
;
2336 sub_ns
->resolved
= 1;
2337 /* Set up procedure symbol. */
2338 sprintf (name
, "__copy_%s", tname
);
2339 gfc_get_symbol (name
, sub_ns
, ©
);
2340 sub_ns
->proc_name
= copy
;
2341 copy
->attr
.flavor
= FL_PROCEDURE
;
2342 copy
->attr
.subroutine
= 1;
2343 copy
->attr
.pure
= 1;
2344 copy
->attr
.artificial
= 1;
2345 copy
->attr
.if_source
= IFSRC_DECL
;
2346 /* This is elemental so that arrays are automatically
2347 treated correctly by the scalarizer. */
2348 copy
->attr
.elemental
= 1;
2349 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2350 copy
->module
= ns
->proc_name
->name
;
2351 gfc_set_sym_referenced (copy
);
2352 /* Set up formal arguments. */
2353 gfc_get_symbol ("src", sub_ns
, &src
);
2354 src
->ts
.type
= BT_DERIVED
;
2355 src
->ts
.u
.derived
= derived
;
2356 src
->attr
.flavor
= FL_VARIABLE
;
2357 src
->attr
.dummy
= 1;
2358 src
->attr
.artificial
= 1;
2359 src
->attr
.intent
= INTENT_IN
;
2360 gfc_set_sym_referenced (src
);
2361 copy
->formal
= gfc_get_formal_arglist ();
2362 copy
->formal
->sym
= src
;
2363 gfc_get_symbol ("dst", sub_ns
, &dst
);
2364 dst
->ts
.type
= BT_DERIVED
;
2365 dst
->ts
.u
.derived
= derived
;
2366 dst
->attr
.flavor
= FL_VARIABLE
;
2367 dst
->attr
.dummy
= 1;
2368 dst
->attr
.artificial
= 1;
2369 dst
->attr
.intent
= INTENT_INOUT
;
2370 gfc_set_sym_referenced (dst
);
2371 copy
->formal
->next
= gfc_get_formal_arglist ();
2372 copy
->formal
->next
->sym
= dst
;
2374 sub_ns
->code
= gfc_get_code ();
2375 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2376 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2377 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2378 /* Set initializer. */
2379 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2380 c
->ts
.interface
= copy
;
2383 /* Add component _final, which contains a procedure pointer to
2384 a wrapper which handles both the freeing of allocatable
2385 components and the calls to finalization subroutines.
2386 Note: The actual wrapper function can only be generated
2387 at resolution time. */
2388 if (!gfc_add_component (vtype
, "_final", &c
))
2390 c
->attr
.proc_pointer
= 1;
2391 c
->attr
.access
= ACCESS_PRIVATE
;
2392 c
->tb
= XCNEW (gfc_typebound_proc
);
2394 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2396 /* Add procedure pointers for type-bound procedures. */
2397 if (!derived
->attr
.unlimited_polymorphic
)
2398 add_procs_to_declared_vtab (derived
, vtype
);
2402 vtab
->ts
.u
.derived
= vtype
;
2403 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2410 /* It is unexpected to have some symbols added at resolution or code
2411 generation time. We commit the changes in order to keep a clean state. */
2414 gfc_commit_symbol (vtab
);
2416 gfc_commit_symbol (vtype
);
2418 gfc_commit_symbol (def_init
);
2420 gfc_commit_symbol (copy
);
2422 gfc_commit_symbol (src
);
2424 gfc_commit_symbol (dst
);
2427 gfc_undo_symbols ();
2433 /* Check if a derived type is finalizable. That is the case if it
2434 (1) has a FINAL subroutine or
2435 (2) has a nonpointer nonallocatable component of finalizable type.
2436 If it is finalizable, return an expression containing the
2437 finalization wrapper. */
2440 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2445 /* (1) Check for FINAL subroutines. */
2446 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2449 /* (2) Check for components of finalizable type. */
2450 for (c
= derived
->components
; c
; c
= c
->next
)
2451 if (c
->ts
.type
== BT_DERIVED
2452 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2453 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2459 /* Make sure vtab is generated. */
2460 vtab
= gfc_find_derived_vtab (derived
);
2463 /* Return finalizer expression. */
2464 gfc_component
*final
;
2465 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2466 gcc_assert (strcmp (final
->name
, "_final") == 0);
2467 gcc_assert (final
->initializer
2468 && final
->initializer
->expr_type
!= EXPR_NULL
);
2469 *final_expr
= final
->initializer
;
2475 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2476 need to support unlimited polymorphism. */
2479 gfc_find_intrinsic_vtab (gfc_typespec
*ts
)
2482 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2483 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2486 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2488 gfc_error ("TODO: Deferred character length variable at %C cannot "
2489 "yet be associated with unlimited polymorphic entities");
2493 if (ts
->type
== BT_UNKNOWN
)
2496 /* Sometimes the typespec is passed from a single call. */
2497 if (ts
->type
== BT_DERIVED
)
2498 return gfc_find_derived_vtab (ts
->u
.derived
);
2500 /* Find the top-level namespace. */
2501 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2505 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
2506 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2507 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2511 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2513 if (ts
->type
== BT_CHARACTER
)
2514 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2517 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2519 sprintf (name
, "__vtab_%s", tname
);
2521 /* Look for the vtab symbol in various namespaces. */
2522 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2524 gfc_find_symbol (name
, ns
, 0, &vtab
);
2528 gfc_get_symbol (name
, ns
, &vtab
);
2529 vtab
->ts
.type
= BT_DERIVED
;
2530 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2531 &gfc_current_locus
))
2533 vtab
->attr
.target
= 1;
2534 vtab
->attr
.save
= SAVE_IMPLICIT
;
2535 vtab
->attr
.vtab
= 1;
2536 vtab
->attr
.access
= ACCESS_PUBLIC
;
2537 gfc_set_sym_referenced (vtab
);
2538 sprintf (name
, "__vtype_%s", tname
);
2540 gfc_find_symbol (name
, ns
, 0, &vtype
);
2545 gfc_namespace
*sub_ns
;
2546 gfc_namespace
*contained
;
2548 gfc_get_symbol (name
, ns
, &vtype
);
2549 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2550 &gfc_current_locus
))
2552 vtype
->attr
.access
= ACCESS_PUBLIC
;
2553 vtype
->attr
.vtype
= 1;
2554 gfc_set_sym_referenced (vtype
);
2556 /* Add component '_hash'. */
2557 if (!gfc_add_component (vtype
, "_hash", &c
))
2559 c
->ts
.type
= BT_INTEGER
;
2561 c
->attr
.access
= ACCESS_PRIVATE
;
2562 hash
= gfc_intrinsic_hash_value (ts
);
2563 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2566 /* Add component '_size'. */
2567 if (!gfc_add_component (vtype
, "_size", &c
))
2569 c
->ts
.type
= BT_INTEGER
;
2571 c
->attr
.access
= ACCESS_PRIVATE
;
2572 if (ts
->type
== BT_CHARACTER
)
2573 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2574 NULL
, charlen
*ts
->kind
);
2576 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2579 /* Add component _extends. */
2580 if (!gfc_add_component (vtype
, "_extends", &c
))
2582 c
->attr
.pointer
= 1;
2583 c
->attr
.access
= ACCESS_PRIVATE
;
2584 c
->ts
.type
= BT_VOID
;
2585 c
->initializer
= gfc_get_null_expr (NULL
);
2587 /* Add component _def_init. */
2588 if (!gfc_add_component (vtype
, "_def_init", &c
))
2590 c
->attr
.pointer
= 1;
2591 c
->attr
.access
= ACCESS_PRIVATE
;
2592 c
->ts
.type
= BT_VOID
;
2593 c
->initializer
= gfc_get_null_expr (NULL
);
2595 /* Add component _copy. */
2596 if (!gfc_add_component (vtype
, "_copy", &c
))
2598 c
->attr
.proc_pointer
= 1;
2599 c
->attr
.access
= ACCESS_PRIVATE
;
2600 c
->tb
= XCNEW (gfc_typebound_proc
);
2603 /* Check to see if copy function already exists. Note
2604 that this is only used for characters of different
2606 contained
= ns
->contained
;
2607 for (; contained
; contained
= contained
->sibling
)
2608 if (contained
->proc_name
2609 && strcmp (name
, contained
->proc_name
->name
) == 0)
2611 copy
= contained
->proc_name
;
2615 /* Set up namespace. */
2616 sub_ns
= gfc_get_namespace (ns
, 0);
2617 sub_ns
->sibling
= ns
->contained
;
2618 ns
->contained
= sub_ns
;
2619 sub_ns
->resolved
= 1;
2620 /* Set up procedure symbol. */
2621 if (ts
->type
!= BT_CHARACTER
)
2622 sprintf (name
, "__copy_%s", tname
);
2624 /* __copy is always the same for characters. */
2625 sprintf (name
, "__copy_character_%d", ts
->kind
);
2626 gfc_get_symbol (name
, sub_ns
, ©
);
2627 sub_ns
->proc_name
= copy
;
2628 copy
->attr
.flavor
= FL_PROCEDURE
;
2629 copy
->attr
.subroutine
= 1;
2630 copy
->attr
.pure
= 1;
2631 copy
->attr
.if_source
= IFSRC_DECL
;
2632 /* This is elemental so that arrays are automatically
2633 treated correctly by the scalarizer. */
2634 copy
->attr
.elemental
= 1;
2635 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2636 copy
->module
= ns
->proc_name
->name
;
2637 gfc_set_sym_referenced (copy
);
2638 /* Set up formal arguments. */
2639 gfc_get_symbol ("src", sub_ns
, &src
);
2640 src
->ts
.type
= ts
->type
;
2641 src
->ts
.kind
= ts
->kind
;
2642 src
->attr
.flavor
= FL_VARIABLE
;
2643 src
->attr
.dummy
= 1;
2644 src
->attr
.intent
= INTENT_IN
;
2645 gfc_set_sym_referenced (src
);
2646 copy
->formal
= gfc_get_formal_arglist ();
2647 copy
->formal
->sym
= src
;
2648 gfc_get_symbol ("dst", sub_ns
, &dst
);
2649 dst
->ts
.type
= ts
->type
;
2650 dst
->ts
.kind
= ts
->kind
;
2651 dst
->attr
.flavor
= FL_VARIABLE
;
2652 dst
->attr
.dummy
= 1;
2653 dst
->attr
.intent
= INTENT_INOUT
;
2654 gfc_set_sym_referenced (dst
);
2655 copy
->formal
->next
= gfc_get_formal_arglist ();
2656 copy
->formal
->next
->sym
= dst
;
2658 sub_ns
->code
= gfc_get_code ();
2659 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2660 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2661 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2663 /* Set initializer. */
2664 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2665 c
->ts
.interface
= copy
;
2667 /* Add component _final. */
2668 if (!gfc_add_component (vtype
, "_final", &c
))
2670 c
->attr
.proc_pointer
= 1;
2671 c
->attr
.access
= ACCESS_PRIVATE
;
2672 c
->tb
= XCNEW (gfc_typebound_proc
);
2674 c
->initializer
= gfc_get_null_expr (NULL
);
2676 vtab
->ts
.u
.derived
= vtype
;
2677 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2684 /* It is unexpected to have some symbols added at resolution or code
2685 generation time. We commit the changes in order to keep a clean state. */
2688 gfc_commit_symbol (vtab
);
2690 gfc_commit_symbol (vtype
);
2692 gfc_commit_symbol (copy
);
2694 gfc_commit_symbol (src
);
2696 gfc_commit_symbol (dst
);
2699 gfc_undo_symbols ();
2705 /* General worker function to find either a type-bound procedure or a
2706 type-bound user operator. */
2709 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2710 const char* name
, bool noaccess
, bool uop
,
2716 /* Set default to failure. */
2720 if (derived
->f2k_derived
)
2721 /* Set correct symbol-root. */
2722 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2723 : derived
->f2k_derived
->tb_sym_root
);
2727 /* Try to find it in the current type's namespace. */
2728 res
= gfc_find_symtree (root
, name
);
2729 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2735 if (!noaccess
&& derived
->attr
.use_assoc
2736 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2739 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2740 name
, derived
->name
, where
);
2748 /* Otherwise, recurse on parent type if derived is an extension. */
2749 if (derived
->attr
.extension
)
2751 gfc_symbol
* super_type
;
2752 super_type
= gfc_get_derived_super_type (derived
);
2753 gcc_assert (super_type
);
2755 return find_typebound_proc_uop (super_type
, t
, name
,
2756 noaccess
, uop
, where
);
2759 /* Nothing found. */
2764 /* Find a type-bound procedure or user operator by name for a derived-type
2765 (looking recursively through the super-types). */
2768 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2769 const char* name
, bool noaccess
, locus
* where
)
2771 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2775 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2776 const char* name
, bool noaccess
, locus
* where
)
2778 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2782 /* Find a type-bound intrinsic operator looking recursively through the
2783 super-type hierarchy. */
2786 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2787 gfc_intrinsic_op op
, bool noaccess
,
2790 gfc_typebound_proc
* res
;
2792 /* Set default to failure. */
2796 /* Try to find it in the current type's namespace. */
2797 if (derived
->f2k_derived
)
2798 res
= derived
->f2k_derived
->tb_op
[op
];
2803 if (res
&& !res
->error
)
2809 if (!noaccess
&& derived
->attr
.use_assoc
2810 && res
->access
== ACCESS_PRIVATE
)
2813 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2814 gfc_op2string (op
), derived
->name
, where
);
2822 /* Otherwise, recurse on parent type if derived is an extension. */
2823 if (derived
->attr
.extension
)
2825 gfc_symbol
* super_type
;
2826 super_type
= gfc_get_derived_super_type (derived
);
2827 gcc_assert (super_type
);
2829 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2833 /* Nothing found. */
2838 /* Get a typebound-procedure symtree or create and insert it if not yet
2839 present. This is like a very simplified version of gfc_get_sym_tree for
2840 tbp-symtrees rather than regular ones. */
2843 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2845 gfc_symtree
*result
;
2847 result
= gfc_find_symtree (*root
, name
);
2850 result
= gfc_new_symtree (root
, name
);
2851 gcc_assert (result
);
2852 result
->n
.tb
= NULL
;