1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2019 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 Only for unlimited polymorphic classes:
38 * _len: An integer(C_SIZE_T) to store the string length when the unlimited
39 polymorphic pointer is used to point to a char array. The '_len'
40 component will be zero when no character array is stored in
43 For each derived type we set up a "vtable" entry, i.e. a structure with the
45 * _hash: A hash value serving as a unique identifier for this type.
46 * _size: The size in bytes of the derived type.
47 * _extends: A pointer to the vtable entry of the parent derived type.
48 * _def_init: A pointer to a default initialized variable of this type.
49 * _copy: A procedure pointer to a copying procedure.
50 * _final: A procedure pointer to a wrapper function, which frees
51 allocatable components and calls FINAL subroutines.
53 After these follow procedure pointer components for the specific
54 type-bound procedures. */
59 #include "coretypes.h"
61 #include "constructor.h"
62 #include "target-memory.h"
64 /* Inserts a derived type component reference in a data reference chain.
65 TS: base type of the ref chain so far, in which we will pick the component
66 REF: the address of the GFC_REF pointer to update
67 NAME: name of the component to insert
68 Note that component insertion makes sense only if we are at the end of
69 the chain (*REF == NULL) or if we are adding a missing "_data" component
70 to access the actual contents of a class object. */
73 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
78 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
80 gfc_find_component (ts
->u
.derived
, name
, true, true, &new_ref
);
82 gfc_get_errors (&wcnt
, &ecnt
);
83 if (ecnt
> 0 && !new_ref
)
85 gcc_assert (new_ref
->u
.c
.component
);
88 new_ref
= new_ref
->next
;
95 /* We need to update the base type in the trailing reference chain to
96 that of the new component. */
98 gcc_assert (strcmp (name
, "_data") == 0);
100 if (new_ref
->next
->type
== REF_COMPONENT
)
101 next
= new_ref
->next
;
102 else if (new_ref
->next
->type
== REF_ARRAY
103 && new_ref
->next
->next
104 && new_ref
->next
->next
->type
== REF_COMPONENT
)
105 next
= new_ref
->next
->next
;
109 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
110 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
111 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
119 /* Tells whether we need to add a "_data" reference to access REF subobject
120 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
121 object accessed by REF is a variable; in other words it is a full object,
125 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
127 /* Only class containers may need the "_data" reference. */
128 if (ts
->type
!= BT_CLASS
)
131 /* Accessing a class container with an array reference is certainly wrong. */
132 if (ref
->type
!= REF_COMPONENT
)
135 /* Accessing the class container's fields is fine. */
136 if (ref
->u
.c
.component
->name
[0] == '_')
139 /* At this point we have a class container with a non class container's field
140 component reference. We don't want to add the "_data" component if we are
141 at the first reference and the symbol's type is an extended derived type.
142 In that case, conv_parent_component_references will do the right thing so
143 it is not absolutely necessary. Omitting it prevents a regression (see
144 class_41.f03) in the interface mapping mechanism. When evaluating string
145 lengths depending on dummy arguments, we create a fake symbol with a type
146 equal to that of the dummy type. However, because of type extension,
147 the backend type (corresponding to the actual argument) can have a
148 different (extended) type. Adding the "_data" component explicitly, using
149 the base type, confuses the gfc_conv_component_ref code which deals with
150 the extended type. */
151 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
154 /* We have a class container with a non class container's field component
155 reference that doesn't fall into the above. */
160 /* Browse through a data reference chain and add the missing "_data" references
161 when a subobject of a class object is accessed without it.
162 Note that it doesn't add the "_data" reference when the class container
163 is the last element in the reference chain. */
166 gfc_fix_class_refs (gfc_expr
*e
)
171 if ((e
->expr_type
!= EXPR_VARIABLE
172 && e
->expr_type
!= EXPR_FUNCTION
)
173 || (e
->expr_type
== EXPR_FUNCTION
174 && e
->value
.function
.isym
!= NULL
))
177 if (e
->expr_type
== EXPR_VARIABLE
)
178 ts
= &e
->symtree
->n
.sym
->ts
;
183 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
184 if (e
->value
.function
.esym
!= NULL
)
185 func
= e
->value
.function
.esym
;
187 func
= e
->symtree
->n
.sym
;
189 if (func
->result
!= NULL
)
190 ts
= &func
->result
->ts
;
195 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
197 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
198 insert_component_ref (ts
, ref
, "_data");
200 if ((*ref
)->type
== REF_COMPONENT
)
201 ts
= &(*ref
)->u
.c
.component
->ts
;
206 /* Insert a reference to the component of the given name.
207 Only to be used with CLASS containers and vtables. */
210 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
213 gfc_ref
**tail
= &(e
->ref
);
214 gfc_ref
*ref
, *next
= NULL
;
215 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
216 while (*tail
!= NULL
)
218 if ((*tail
)->type
== REF_COMPONENT
)
220 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
222 && (*tail
)->next
->type
== REF_ARRAY
223 && (*tail
)->next
->next
== NULL
)
225 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
227 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
229 tail
= &((*tail
)->next
);
231 if (derived
->components
&& derived
->components
->next
&&
232 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
233 derived
->components
->next
->ts
.u
.derived
== NULL
)
235 /* Fix up missing vtype. */
236 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
238 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
240 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
243 /* Avoid losing memory. */
244 gfc_free_ref_list (*tail
);
245 c
= gfc_find_component (derived
, name
, true, true, tail
);
248 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
257 /* This is used to add both the _data component reference and an array
258 reference to class expressions. Used in translation of intrinsic
259 array inquiry functions. */
262 gfc_add_class_array_ref (gfc_expr
*e
)
264 int rank
= CLASS_DATA (e
)->as
->rank
;
265 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
267 gfc_add_data_component (e
);
269 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
272 if (ref
->type
!= REF_ARRAY
)
274 ref
->next
= gfc_get_ref ();
276 ref
->type
= REF_ARRAY
;
277 ref
->u
.ar
.type
= AR_FULL
;
283 /* Unfortunately, class array expressions can appear in various conditions;
284 with and without both _data component and an arrayspec. This function
285 deals with that variability. The previous reference to 'ref' is to a
289 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
291 bool no_data
= false;
292 bool with_data
= false;
294 /* An array reference with no _data component. */
295 if (ref
&& ref
->type
== REF_ARRAY
297 && ref
->u
.ar
.type
!= AR_ELEMENT
)
300 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
304 /* Cover cases where _data appears, with or without an array ref. */
305 if (ref
&& ref
->type
== REF_COMPONENT
306 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
314 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
315 && ref
->type
== REF_COMPONENT
316 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
320 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
324 return no_data
|| with_data
;
328 /* Returns true if the expression contains a reference to a class
329 array. Notice that class array elements return false. */
332 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
342 /* Is this a class array object? ie. Is the symbol of type class? */
344 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
345 && CLASS_DATA (e
->symtree
->n
.sym
)
346 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
347 && class_array_ref_detected (e
->ref
, full_array
))
350 /* Or is this a class array component reference? */
351 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
353 if (ref
->type
== REF_COMPONENT
354 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
355 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
356 && class_array_ref_detected (ref
->next
, full_array
))
364 /* Returns true if the expression is a reference to a class
365 scalar. This function is necessary because such expressions
366 can be dressed with a reference to the _data component and so
367 have a type other than BT_CLASS. */
370 gfc_is_class_scalar_expr (gfc_expr
*e
)
377 /* Is this a class object? */
379 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
380 && CLASS_DATA (e
->symtree
->n
.sym
)
381 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
383 || (e
->ref
->type
== REF_COMPONENT
384 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
385 && e
->ref
->next
== NULL
)))
388 /* Or is the final reference BT_CLASS or _data? */
389 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
391 if (ref
->type
== REF_COMPONENT
392 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
393 && CLASS_DATA (ref
->u
.c
.component
)
394 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
395 && (ref
->next
== NULL
396 || (ref
->next
->type
== REF_COMPONENT
397 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
398 && ref
->next
->next
== NULL
)))
406 /* Tells whether the expression E is a reference to a (scalar) class container.
407 Scalar because array class containers usually have an array reference after
408 them, and gfc_fix_class_refs will add the missing "_data" component reference
412 gfc_is_class_container_ref (gfc_expr
*e
)
417 if (e
->expr_type
!= EXPR_VARIABLE
)
418 return e
->ts
.type
== BT_CLASS
;
420 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
425 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
427 if (ref
->type
!= REF_COMPONENT
)
429 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
439 /* Build an initializer for CLASS pointers,
440 initializing the _data component to the init_expr (or NULL) and the _vptr
441 component to the corresponding type (or the declared type, given by ts). */
444 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
448 gfc_symbol
*vtab
= NULL
;
450 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
451 vtab
= gfc_find_vtab (&init_expr
->ts
);
453 vtab
= gfc_find_vtab (ts
);
455 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
456 &ts
->u
.derived
->declared_at
);
459 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
461 gfc_constructor
*ctor
= gfc_constructor_get();
462 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
463 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
464 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
465 ctor
->expr
= gfc_copy_expr (init_expr
);
467 ctor
->expr
= gfc_get_null_expr (NULL
);
468 gfc_constructor_append (&init
->value
.constructor
, ctor
);
475 /* Create a unique string identifier for a derived type, composed of its name
476 and module name. This is used to construct unique names for the class
477 containers and vtab symbols. */
480 get_unique_type_string (char *string
, gfc_symbol
*derived
)
482 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
483 if (derived
->attr
.unlimited_polymorphic
)
484 strcpy (dt_name
, "STAR");
486 strcpy (dt_name
, gfc_dt_upper_string (derived
->name
));
487 if (derived
->attr
.unlimited_polymorphic
)
488 sprintf (string
, "_%s", dt_name
);
489 else if (derived
->module
)
490 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
491 else if (derived
->ns
->proc_name
)
492 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
494 sprintf (string
, "_%s", dt_name
);
498 /* A relative of 'get_unique_type_string' which makes sure the generated
499 string will not be too long (replacing it by a hash string if needed). */
502 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
504 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
505 get_unique_type_string (&tmp
[0], derived
);
506 /* If string is too long, use hash value in hex representation (allow for
507 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
508 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
509 where %d is the (co)rank which can be up to n = 15. */
510 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
512 int h
= gfc_hash_value (derived
);
513 sprintf (string
, "%X", h
);
516 strcpy (string
, tmp
);
520 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
523 gfc_hash_value (gfc_symbol
*sym
)
525 unsigned int hash
= 0;
526 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
529 get_unique_type_string (&c
[0], sym
);
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 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
544 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
546 unsigned int hash
= 0;
547 const char *c
= gfc_typename (ts
);
552 for (i
= 0; i
< len
; i
++)
553 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
555 /* Return the hash but take the modulus for the sake of module read,
556 even though this slightly increases the chance of collision. */
557 return (hash
% 100000000);
561 /* Get the _len component from a class/derived object storing a string.
562 For unlimited polymorphic entities a ref to the _data component is available
563 while a ref to the _len component is needed. This routine traverese the
564 ref-chain and strips the last ref to a _data from it replacing it with a
565 ref to the _len component. */
568 gfc_get_len_component (gfc_expr
*e
, int k
)
571 gfc_ref
*ref
, **last
;
573 ptr
= gfc_copy_expr (e
);
575 /* We need to remove the last _data component ref from ptr. */
581 && ref
->type
== REF_COMPONENT
582 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
584 gfc_free_ref_list (ref
);
591 /* And replace if with a ref to the _len component. */
592 gfc_add_len_component (ptr
);
593 if (k
!= ptr
->ts
.kind
)
597 ts
.type
= BT_INTEGER
;
599 gfc_convert_type_warn (ptr
, &ts
, 2, 0);
605 /* Build a polymorphic CLASS entity, using the symbol that comes from
606 build_sym. A CLASS entity is represented by an encapsulating type,
607 which contains the declared type as '_data' component, plus a pointer
608 component '_vptr' which determines the dynamic type. When this CLASS
609 entity is unlimited polymorphic, then also add a component '_len' to
610 store the length of string when that is stored in it. */
613 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
616 char tname
[GFC_MAX_SYMBOL_LEN
+1];
626 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
628 gfc_error ("Assumed size polymorphic objects or components, such "
629 "as that at %C, have not yet been implemented");
634 /* Class container has already been built. */
637 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
638 || attr
->select_type_temporary
|| attr
->associate_var
;
641 /* We cannot build the class container yet. */
644 /* Determine the name of the encapsulating type. */
645 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
646 get_unique_hashed_string (tname
, ts
->u
.derived
);
647 if ((*as
) && attr
->allocatable
)
648 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
649 else if ((*as
) && attr
->pointer
)
650 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
652 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
653 else if (attr
->pointer
)
654 name
= xasprintf ("__class_%s_p", tname
);
655 else if (attr
->allocatable
)
656 name
= xasprintf ("__class_%s_a", tname
);
658 name
= xasprintf ("__class_%s_t", tname
);
660 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
662 /* Find the top-level namespace. */
663 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
668 ns
= ts
->u
.derived
->ns
;
670 gfc_find_symbol (name
, ns
, 0, &fclass
);
674 /* If not there, create a new symbol. */
675 fclass
= gfc_new_symbol (name
, ns
);
676 st
= gfc_new_symtree (&ns
->sym_root
, name
);
678 gfc_set_sym_referenced (fclass
);
680 fclass
->ts
.type
= BT_UNKNOWN
;
681 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
682 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
683 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
684 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
688 /* Add component '_data'. */
689 if (!gfc_add_component (fclass
, "_data", &c
))
692 c
->ts
.type
= BT_DERIVED
;
693 c
->attr
.access
= ACCESS_PRIVATE
;
694 c
->ts
.u
.derived
= ts
->u
.derived
;
695 c
->attr
.class_pointer
= attr
->pointer
;
696 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
697 || attr
->select_type_temporary
;
698 c
->attr
.allocatable
= attr
->allocatable
;
699 c
->attr
.dimension
= attr
->dimension
;
700 c
->attr
.codimension
= attr
->codimension
;
701 c
->attr
.abstract
= fclass
->attr
.abstract
;
703 c
->initializer
= NULL
;
705 /* Add component '_vptr'. */
706 if (!gfc_add_component (fclass
, "_vptr", &c
))
708 c
->ts
.type
= BT_DERIVED
;
709 c
->attr
.access
= ACCESS_PRIVATE
;
712 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
714 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
716 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
718 /* Add component '_len'. Only unlimited polymorphic pointers may
719 have a string assigned to them, i.e., only those need the _len
721 if (!gfc_add_component (fclass
, "_len", &c
))
723 c
->ts
.type
= BT_INTEGER
;
724 c
->ts
.kind
= gfc_charlen_int_kind
;
725 c
->attr
.access
= ACCESS_PRIVATE
;
726 c
->attr
.artificial
= 1;
729 /* Build vtab later. */
730 c
->ts
.u
.derived
= NULL
;
733 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
735 /* Since the extension field is 8 bit wide, we can only have
736 up to 255 extension levels. */
737 if (ts
->u
.derived
->attr
.extension
== 255)
739 gfc_error ("Maximum extension level reached with type %qs at %L",
740 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
744 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
745 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
746 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
749 fclass
->attr
.is_class
= 1;
750 ts
->u
.derived
= fclass
;
751 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
758 /* Add a procedure pointer component to the vtype
759 to represent a specific type-bound procedure. */
762 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
766 if (tb
->non_overridable
&& !tb
->overridden
)
769 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
773 /* Add procedure component. */
774 if (!gfc_add_component (vtype
, name
, &c
))
778 c
->tb
= XCNEW (gfc_typebound_proc
);
781 c
->attr
.procedure
= 1;
782 c
->attr
.proc_pointer
= 1;
783 c
->attr
.flavor
= FL_PROCEDURE
;
784 c
->attr
.access
= ACCESS_PRIVATE
;
785 c
->attr
.external
= 1;
787 c
->attr
.if_source
= IFSRC_IFBODY
;
789 else if (c
->attr
.proc_pointer
&& c
->tb
)
797 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
798 c
->ts
.interface
= ifc
;
800 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
801 c
->attr
.pure
= ifc
->attr
.pure
;
806 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
809 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
815 add_procs_to_declared_vtab1 (st
->left
, vtype
);
818 add_procs_to_declared_vtab1 (st
->right
, vtype
);
820 if (st
->n
.tb
&& !st
->n
.tb
->error
821 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
822 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
826 /* Copy procedure pointers components from the parent type. */
829 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
834 vtab
= gfc_find_derived_vtab (declared
);
836 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
838 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
841 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
846 /* Returns true if any of its nonpointer nonallocatable components or
847 their nonpointer nonallocatable subcomponents has a finalization
851 has_finalizer_component (gfc_symbol
*derived
)
855 for (c
= derived
->components
; c
; c
= c
->next
)
856 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
)
858 if (c
->ts
.u
.derived
->f2k_derived
859 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
862 /* Stop infinite recursion through this function by inhibiting
863 calls when the derived type and that of the component are
865 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
866 && has_finalizer_component (c
->ts
.u
.derived
))
874 comp_is_finalizable (gfc_component
*comp
)
876 if (comp
->attr
.proc_pointer
)
878 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
880 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
881 && (comp
->ts
.u
.derived
->attr
.alloc_comp
882 || has_finalizer_component (comp
->ts
.u
.derived
)
883 || (comp
->ts
.u
.derived
->f2k_derived
884 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
886 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
887 && CLASS_DATA (comp
)->attr
.allocatable
)
894 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
895 neither allocatable nor a pointer but has a finalizer, call it. If it
896 is a nonpointer component with allocatable components or has finalizers, walk
897 them. Either of them is required; other nonallocatables and pointers aren't
899 Note: If the component is allocatable, the DEALLOCATE handling takes care
900 of calling the appropriate finalizers, coarray deregistering, and
901 deallocation of allocatable subcomponents. */
904 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
905 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
906 gfc_namespace
*sub_ns
)
911 if (!comp_is_finalizable (comp
))
917 e
= gfc_copy_expr (expr
);
919 e
->ref
= ref
= gfc_get_ref ();
922 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
924 ref
->next
= gfc_get_ref ();
927 ref
->type
= REF_COMPONENT
;
928 ref
->u
.c
.sym
= derived
;
929 ref
->u
.c
.component
= comp
;
932 if (comp
->attr
.dimension
|| comp
->attr
.codimension
933 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
934 && (CLASS_DATA (comp
)->attr
.dimension
935 || CLASS_DATA (comp
)->attr
.codimension
)))
937 ref
->next
= gfc_get_ref ();
938 ref
->next
->type
= REF_ARRAY
;
939 ref
->next
->u
.ar
.dimen
= 0;
940 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
942 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
943 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
946 /* Call DEALLOCATE (comp, stat=ignore). */
947 if (comp
->attr
.allocatable
948 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
949 && CLASS_DATA (comp
)->attr
.allocatable
))
951 gfc_code
*dealloc
, *block
= NULL
;
953 /* Add IF (fini_coarray). */
954 if (comp
->attr
.codimension
955 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
956 && CLASS_DATA (comp
)->attr
.codimension
))
958 block
= gfc_get_code (EXEC_IF
);
961 (*code
)->next
= block
;
962 (*code
) = (*code
)->next
;
967 block
->block
= gfc_get_code (EXEC_IF
);
968 block
= block
->block
;
969 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
972 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
974 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
975 dealloc
->ext
.alloc
.list
->expr
= e
;
976 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
978 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
979 cond
->block
= gfc_get_code (EXEC_IF
);
980 cond
->block
->expr1
= gfc_get_expr ();
981 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
982 cond
->block
->expr1
->where
= gfc_current_locus
;
983 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
984 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
985 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
986 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
987 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
988 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
989 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
990 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
991 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
992 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
993 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
994 cond
->block
->next
= dealloc
;
1000 (*code
)->next
= cond
;
1001 (*code
) = (*code
)->next
;
1006 else if (comp
->ts
.type
== BT_DERIVED
1007 && comp
->ts
.u
.derived
->f2k_derived
1008 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1010 /* Call FINAL_WRAPPER (comp); */
1011 gfc_code
*final_wrap
;
1015 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1016 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1017 if (strcmp (c
->name
, "_final") == 0)
1021 final_wrap
= gfc_get_code (EXEC_CALL
);
1022 final_wrap
->symtree
= c
->initializer
->symtree
;
1023 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1024 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1025 final_wrap
->ext
.actual
->expr
= e
;
1029 (*code
)->next
= final_wrap
;
1030 (*code
) = (*code
)->next
;
1033 (*code
) = final_wrap
;
1039 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1040 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1044 comp
->finalized
= true;
1048 /* Generate code equivalent to
1049 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1050 + offset, c_ptr), ptr). */
1053 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1054 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1057 gfc_expr
*expr
, *expr2
;
1059 /* C_F_POINTER(). */
1060 block
= gfc_get_code (EXEC_CALL
);
1061 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1062 block
->resolved_sym
= block
->symtree
->n
.sym
;
1063 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1064 block
->resolved_sym
->attr
.intrinsic
= 1;
1065 block
->resolved_sym
->attr
.subroutine
= 1;
1066 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1067 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1068 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1069 gfc_commit_symbol (block
->resolved_sym
);
1071 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1072 block
->ext
.actual
= gfc_get_actual_arglist ();
1073 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1074 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1076 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1078 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1080 /* TRANSFER's first argument: C_LOC (array). */
1081 expr
= gfc_get_expr ();
1082 expr
->expr_type
= EXPR_FUNCTION
;
1083 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1084 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1085 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1086 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1087 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1088 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1089 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1090 expr
->value
.function
.actual
->expr
1091 = gfc_lval_expr_from_sym (array
);
1092 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1093 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1094 expr
->ts
.type
= BT_INTEGER
;
1095 expr
->ts
.kind
= gfc_index_integer_kind
;
1096 expr
->where
= gfc_current_locus
;
1099 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1100 gfc_current_locus
, 3, expr
,
1101 gfc_get_int_expr (gfc_index_integer_kind
,
1103 expr2
->ts
.type
= BT_INTEGER
;
1104 expr2
->ts
.kind
= gfc_index_integer_kind
;
1106 /* <array addr> + <offset>. */
1107 block
->ext
.actual
->expr
= gfc_get_expr ();
1108 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1109 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1110 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1111 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1112 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1113 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1115 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1116 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1117 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1118 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1124 /* Calculates the offset to the (idx+1)th element of an array, taking the
1125 stride into account. It generates the code:
1128 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1130 offset = offset * byte_stride. */
1133 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1134 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1135 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1136 gfc_code
*block
, gfc_namespace
*sub_ns
)
1139 gfc_expr
*expr
, *expr2
;
1142 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1143 block
= block
->next
;
1144 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1145 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1148 iter
= gfc_get_iterator ();
1149 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1150 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1151 iter
->end
= gfc_copy_expr (rank
);
1152 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1153 block
->next
= gfc_get_code (EXEC_DO
);
1154 block
= block
->next
;
1155 block
->ext
.iterator
= iter
;
1156 block
->block
= gfc_get_code (EXEC_DO
);
1158 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1161 /* mod (idx, sizes(idx2)). */
1162 expr
= gfc_lval_expr_from_sym (sizes
);
1163 expr
->ref
= gfc_get_ref ();
1164 expr
->ref
->type
= REF_ARRAY
;
1165 expr
->ref
->u
.ar
.as
= sizes
->as
;
1166 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1167 expr
->ref
->u
.ar
.dimen
= 1;
1168 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1169 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1170 expr
->where
= sizes
->declared_at
;
1172 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1173 gfc_current_locus
, 2,
1174 gfc_lval_expr_from_sym (idx
), expr
);
1177 /* (...) / sizes(idx2-1). */
1178 expr2
= gfc_get_expr ();
1179 expr2
->expr_type
= EXPR_OP
;
1180 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1181 expr2
->value
.op
.op1
= expr
;
1182 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1183 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1184 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1185 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1186 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1187 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1188 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1189 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1190 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1191 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1192 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1193 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1194 = gfc_lval_expr_from_sym (idx2
);
1195 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1196 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1197 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1198 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1199 expr2
->ts
= idx
->ts
;
1200 expr2
->where
= gfc_current_locus
;
1202 /* ... * strides(idx2). */
1203 expr
= gfc_get_expr ();
1204 expr
->expr_type
= EXPR_OP
;
1205 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1206 expr
->value
.op
.op1
= expr2
;
1207 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1208 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1209 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1210 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1211 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1212 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1213 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1214 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1216 expr
->where
= gfc_current_locus
;
1218 /* offset = offset + ... */
1219 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1220 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1221 block
->block
->next
->expr2
= gfc_get_expr ();
1222 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1223 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1224 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1225 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1226 block
->block
->next
->expr2
->ts
= idx
->ts
;
1227 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1229 /* After the loop: offset = offset * byte_stride. */
1230 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1231 block
= block
->next
;
1232 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1233 block
->expr2
= gfc_get_expr ();
1234 block
->expr2
->expr_type
= EXPR_OP
;
1235 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1236 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1237 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1238 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1239 block
->expr2
->where
= gfc_current_locus
;
1244 /* Insert code of the following form:
1247 integer(c_intptr_t) :: i
1249 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1250 && (is_contiguous || !final_rank3->attr.contiguous
1251 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1252 || 0 == STORAGE_SIZE (array)) then
1253 call final_rank3 (array)
1256 integer(c_intptr_t) :: offset, j
1257 type(t) :: tmp(shape (array))
1259 do i = 0, size (array)-1
1260 offset = obtain_offset(i, strides, sizes, byte_stride)
1261 addr = transfer (c_loc (array), addr) + offset
1262 call c_f_pointer (transfer (addr, cptr), ptr)
1264 addr = transfer (c_loc (tmp), addr)
1265 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1266 call c_f_pointer (transfer (addr, cptr), ptr2)
1269 call final_rank3 (tmp)
1275 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1276 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1277 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1279 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1280 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1281 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1282 gfc_namespace
*sub_ns
)
1284 gfc_symbol
*tmp_array
, *ptr2
;
1285 gfc_expr
*size_expr
, *offset2
, *expr
;
1291 block
->next
= gfc_get_code (EXEC_IF
);
1292 block
= block
->next
;
1294 block
->block
= gfc_get_code (EXEC_IF
);
1295 block
= block
->block
;
1297 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1298 size_expr
= gfc_get_expr ();
1299 size_expr
->where
= gfc_current_locus
;
1300 size_expr
->expr_type
= EXPR_OP
;
1301 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1303 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1304 size_expr
->value
.op
.op1
1305 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1306 "storage_size", gfc_current_locus
, 2,
1307 gfc_lval_expr_from_sym (array
),
1308 gfc_get_int_expr (gfc_index_integer_kind
,
1311 /* NUMERIC_STORAGE_SIZE. */
1312 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1313 gfc_character_storage_size
);
1314 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1315 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1317 /* IF condition: (stride == size_expr
1318 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1320 || 0 == size_expr. */
1321 block
->expr1
= gfc_get_expr ();
1322 block
->expr1
->ts
.type
= BT_LOGICAL
;
1323 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1324 block
->expr1
->expr_type
= EXPR_OP
;
1325 block
->expr1
->where
= gfc_current_locus
;
1327 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1329 /* byte_stride == size_expr */
1330 expr
= gfc_get_expr ();
1331 expr
->ts
.type
= BT_LOGICAL
;
1332 expr
->ts
.kind
= gfc_default_logical_kind
;
1333 expr
->expr_type
= EXPR_OP
;
1334 expr
->where
= gfc_current_locus
;
1335 expr
->value
.op
.op
= INTRINSIC_EQ
;
1337 = gfc_lval_expr_from_sym (byte_stride
);
1338 expr
->value
.op
.op2
= size_expr
;
1340 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1341 add is_contiguous check. */
1343 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1344 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1347 expr2
= gfc_get_expr ();
1348 expr2
->ts
.type
= BT_LOGICAL
;
1349 expr2
->ts
.kind
= gfc_default_logical_kind
;
1350 expr2
->expr_type
= EXPR_OP
;
1351 expr2
->where
= gfc_current_locus
;
1352 expr2
->value
.op
.op
= INTRINSIC_AND
;
1353 expr2
->value
.op
.op1
= expr
;
1354 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1358 block
->expr1
->value
.op
.op1
= expr
;
1360 /* 0 == size_expr */
1361 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1362 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1363 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1364 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1365 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1366 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1367 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1368 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1369 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1371 /* IF body: call final subroutine. */
1372 block
->next
= gfc_get_code (EXEC_CALL
);
1373 block
->next
->symtree
= fini
->proc_tree
;
1374 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1375 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1376 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1377 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1378 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1382 block
->block
= gfc_get_code (EXEC_IF
);
1383 block
= block
->block
;
1385 /* BLOCK ... END BLOCK. */
1386 block
->next
= gfc_get_code (EXEC_BLOCK
);
1387 block
= block
->next
;
1389 ns
= gfc_build_block_ns (sub_ns
);
1390 block
->ext
.block
.ns
= ns
;
1391 block
->ext
.block
.assoc
= NULL
;
1393 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1394 ptr2
->ts
.type
= BT_DERIVED
;
1395 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1396 ptr2
->attr
.flavor
= FL_VARIABLE
;
1397 ptr2
->attr
.pointer
= 1;
1398 ptr2
->attr
.artificial
= 1;
1399 gfc_set_sym_referenced (ptr2
);
1400 gfc_commit_symbol (ptr2
);
1402 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1403 tmp_array
->ts
.type
= BT_DERIVED
;
1404 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1405 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1406 tmp_array
->attr
.dimension
= 1;
1407 tmp_array
->attr
.artificial
= 1;
1408 tmp_array
->as
= gfc_get_array_spec();
1409 tmp_array
->attr
.intent
= INTENT_INOUT
;
1410 tmp_array
->as
->type
= AS_EXPLICIT
;
1411 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1413 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1415 gfc_expr
*shape_expr
;
1416 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1418 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1420 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1421 gfc_current_locus
, 3,
1422 gfc_lval_expr_from_sym (array
),
1423 gfc_get_int_expr (gfc_default_integer_kind
,
1425 gfc_get_int_expr (gfc_default_integer_kind
,
1427 gfc_index_integer_kind
));
1428 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1429 tmp_array
->as
->upper
[i
] = shape_expr
;
1431 gfc_set_sym_referenced (tmp_array
);
1432 gfc_commit_symbol (tmp_array
);
1435 iter
= gfc_get_iterator ();
1436 iter
->var
= gfc_lval_expr_from_sym (idx
);
1437 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1438 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1439 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1441 block
= gfc_get_code (EXEC_DO
);
1443 block
->ext
.iterator
= iter
;
1444 block
->block
= gfc_get_code (EXEC_DO
);
1446 /* Offset calculation for the new array: idx * size of type (in bytes). */
1447 offset2
= gfc_get_expr ();
1448 offset2
->expr_type
= EXPR_OP
;
1449 offset2
->where
= gfc_current_locus
;
1450 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1451 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1452 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1453 offset2
->ts
= byte_stride
->ts
;
1455 /* Offset calculation of "array". */
1456 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1457 byte_stride
, rank
, block
->block
, sub_ns
);
1460 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1461 + idx * stride, c_ptr), ptr). */
1462 block2
->next
= finalization_scalarizer (array
, ptr
,
1463 gfc_lval_expr_from_sym (offset
),
1465 block2
= block2
->next
;
1466 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1467 block2
= block2
->next
;
1470 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1471 block2
= block2
->next
;
1472 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1473 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1475 /* Call now the user's final subroutine. */
1476 block
->next
= gfc_get_code (EXEC_CALL
);
1477 block
= block
->next
;
1478 block
->symtree
= fini
->proc_tree
;
1479 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1480 block
->ext
.actual
= gfc_get_actual_arglist ();
1481 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1483 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1489 iter
= gfc_get_iterator ();
1490 iter
->var
= gfc_lval_expr_from_sym (idx
);
1491 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1492 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1493 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1495 block
->next
= gfc_get_code (EXEC_DO
);
1496 block
= block
->next
;
1497 block
->ext
.iterator
= iter
;
1498 block
->block
= gfc_get_code (EXEC_DO
);
1500 /* Offset calculation of "array". */
1501 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1502 byte_stride
, rank
, block
->block
, sub_ns
);
1505 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1506 + offset, c_ptr), ptr). */
1507 block2
->next
= finalization_scalarizer (array
, ptr
,
1508 gfc_lval_expr_from_sym (offset
),
1510 block2
= block2
->next
;
1511 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1512 gfc_copy_expr (offset2
), sub_ns
);
1513 block2
= block2
->next
;
1516 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1517 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1518 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1522 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1523 derived type "derived". The function first calls the approriate FINAL
1524 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1525 components (but not the inherited ones). Last, it calls the wrapper
1526 subroutine of the parent. The generated wrapper procedure takes as argument
1527 an assumed-rank array.
1528 If neither allocatable components nor FINAL subroutines exists, the vtab
1529 will contain a NULL pointer.
1530 The generated function has the form
1531 _final(assumed-rank array, stride, skip_corarray)
1532 where the array has to be contiguous (except of the lowest dimension). The
1533 stride (in bytes) is used to allow different sizes for ancestor types by
1534 skipping over the additionally added components in the scalarizer. If
1535 "fini_coarray" is false, coarray components are not finalized to allow for
1536 the correct semantic with intrinsic assignment. */
1539 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1540 const char *tname
, gfc_component
*vtab_final
)
1542 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1543 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1544 gfc_component
*comp
;
1545 gfc_namespace
*sub_ns
;
1546 gfc_code
*last_code
, *block
;
1548 bool finalizable_comp
= false;
1549 bool expr_null_wrapper
= false;
1550 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1553 if (derived
->attr
.unlimited_polymorphic
)
1555 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1559 /* Search for the ancestor's finalizers. */
1560 if (derived
->attr
.extension
&& derived
->components
1561 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1562 || has_finalizer_component (derived
)))
1565 gfc_component
*comp
;
1567 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1568 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1569 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1571 ancestor_wrapper
= comp
->initializer
;
1576 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1577 components: Return a NULL() expression; we defer this a bit to have have
1578 an interface declaration. */
1579 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1580 && !derived
->attr
.alloc_comp
1581 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1582 && !has_finalizer_component (derived
))
1583 expr_null_wrapper
= true;
1585 /* Check whether there are new allocatable components. */
1586 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1588 if (comp
== derived
->components
&& derived
->attr
.extension
1589 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1592 finalizable_comp
|= comp_is_finalizable (comp
);
1595 /* If there is no new finalizer and no new allocatable, return with
1596 an expr to the ancestor's one. */
1597 if (!expr_null_wrapper
&& !finalizable_comp
1598 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1600 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1601 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1602 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1603 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1607 /* We now create a wrapper, which does the following:
1608 1. Call the suitable finalization subroutine for this type
1609 2. Loop over all noninherited allocatable components and noninherited
1610 components with allocatable components and DEALLOCATE those; this will
1611 take care of finalizers, coarray deregistering and allocatable
1613 3. Call the ancestor's finalizer. */
1615 /* Declare the wrapper function; it takes an assumed-rank array
1616 and a VALUE logical as arguments. */
1618 /* Set up the namespace. */
1619 sub_ns
= gfc_get_namespace (ns
, 0);
1620 sub_ns
->sibling
= ns
->contained
;
1621 if (!expr_null_wrapper
)
1622 ns
->contained
= sub_ns
;
1623 sub_ns
->resolved
= 1;
1625 /* Set up the procedure symbol. */
1626 name
= xasprintf ("__final_%s", tname
);
1627 gfc_get_symbol (name
, sub_ns
, &final
);
1628 sub_ns
->proc_name
= final
;
1629 final
->attr
.flavor
= FL_PROCEDURE
;
1630 final
->attr
.function
= 1;
1631 final
->attr
.pure
= 0;
1632 final
->attr
.recursive
= 1;
1633 final
->result
= final
;
1634 final
->ts
.type
= BT_INTEGER
;
1636 final
->attr
.artificial
= 1;
1637 final
->attr
.always_explicit
= 1;
1638 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1639 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1640 final
->module
= ns
->proc_name
->name
;
1641 gfc_set_sym_referenced (final
);
1642 gfc_commit_symbol (final
);
1644 /* Set up formal argument. */
1645 gfc_get_symbol ("array", sub_ns
, &array
);
1646 array
->ts
.type
= BT_DERIVED
;
1647 array
->ts
.u
.derived
= derived
;
1648 array
->attr
.flavor
= FL_VARIABLE
;
1649 array
->attr
.dummy
= 1;
1650 array
->attr
.contiguous
= 1;
1651 array
->attr
.dimension
= 1;
1652 array
->attr
.artificial
= 1;
1653 array
->as
= gfc_get_array_spec();
1654 array
->as
->type
= AS_ASSUMED_RANK
;
1655 array
->as
->rank
= -1;
1656 array
->attr
.intent
= INTENT_INOUT
;
1657 gfc_set_sym_referenced (array
);
1658 final
->formal
= gfc_get_formal_arglist ();
1659 final
->formal
->sym
= array
;
1660 gfc_commit_symbol (array
);
1662 /* Set up formal argument. */
1663 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1664 byte_stride
->ts
.type
= BT_INTEGER
;
1665 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1666 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1667 byte_stride
->attr
.dummy
= 1;
1668 byte_stride
->attr
.value
= 1;
1669 byte_stride
->attr
.artificial
= 1;
1670 gfc_set_sym_referenced (byte_stride
);
1671 final
->formal
->next
= gfc_get_formal_arglist ();
1672 final
->formal
->next
->sym
= byte_stride
;
1673 gfc_commit_symbol (byte_stride
);
1675 /* Set up formal argument. */
1676 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1677 fini_coarray
->ts
.type
= BT_LOGICAL
;
1678 fini_coarray
->ts
.kind
= 1;
1679 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1680 fini_coarray
->attr
.dummy
= 1;
1681 fini_coarray
->attr
.value
= 1;
1682 fini_coarray
->attr
.artificial
= 1;
1683 gfc_set_sym_referenced (fini_coarray
);
1684 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1685 final
->formal
->next
->next
->sym
= fini_coarray
;
1686 gfc_commit_symbol (fini_coarray
);
1688 /* Return with a NULL() expression but with an interface which has
1689 the formal arguments. */
1690 if (expr_null_wrapper
)
1692 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1693 vtab_final
->ts
.interface
= final
;
1697 /* Local variables. */
1699 gfc_get_symbol ("idx", sub_ns
, &idx
);
1700 idx
->ts
.type
= BT_INTEGER
;
1701 idx
->ts
.kind
= gfc_index_integer_kind
;
1702 idx
->attr
.flavor
= FL_VARIABLE
;
1703 idx
->attr
.artificial
= 1;
1704 gfc_set_sym_referenced (idx
);
1705 gfc_commit_symbol (idx
);
1707 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1708 idx2
->ts
.type
= BT_INTEGER
;
1709 idx2
->ts
.kind
= gfc_index_integer_kind
;
1710 idx2
->attr
.flavor
= FL_VARIABLE
;
1711 idx2
->attr
.artificial
= 1;
1712 gfc_set_sym_referenced (idx2
);
1713 gfc_commit_symbol (idx2
);
1715 gfc_get_symbol ("offset", sub_ns
, &offset
);
1716 offset
->ts
.type
= BT_INTEGER
;
1717 offset
->ts
.kind
= gfc_index_integer_kind
;
1718 offset
->attr
.flavor
= FL_VARIABLE
;
1719 offset
->attr
.artificial
= 1;
1720 gfc_set_sym_referenced (offset
);
1721 gfc_commit_symbol (offset
);
1723 /* Create RANK expression. */
1724 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1725 gfc_current_locus
, 1,
1726 gfc_lval_expr_from_sym (array
));
1727 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1728 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1730 /* Create is_contiguous variable. */
1731 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1732 is_contiguous
->ts
.type
= BT_LOGICAL
;
1733 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1734 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1735 is_contiguous
->attr
.artificial
= 1;
1736 gfc_set_sym_referenced (is_contiguous
);
1737 gfc_commit_symbol (is_contiguous
);
1739 /* Create "sizes(0..rank)" variable, which contains the multiplied
1740 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1741 sizes(2) = sizes(1) * extent(dim=2) etc. */
1742 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1743 sizes
->ts
.type
= BT_INTEGER
;
1744 sizes
->ts
.kind
= gfc_index_integer_kind
;
1745 sizes
->attr
.flavor
= FL_VARIABLE
;
1746 sizes
->attr
.dimension
= 1;
1747 sizes
->attr
.artificial
= 1;
1748 sizes
->as
= gfc_get_array_spec();
1749 sizes
->attr
.intent
= INTENT_INOUT
;
1750 sizes
->as
->type
= AS_EXPLICIT
;
1751 sizes
->as
->rank
= 1;
1752 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1753 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1754 gfc_set_sym_referenced (sizes
);
1755 gfc_commit_symbol (sizes
);
1757 /* Create "strides(1..rank)" variable, which contains the strides per
1759 gfc_get_symbol ("strides", sub_ns
, &strides
);
1760 strides
->ts
.type
= BT_INTEGER
;
1761 strides
->ts
.kind
= gfc_index_integer_kind
;
1762 strides
->attr
.flavor
= FL_VARIABLE
;
1763 strides
->attr
.dimension
= 1;
1764 strides
->attr
.artificial
= 1;
1765 strides
->as
= gfc_get_array_spec();
1766 strides
->attr
.intent
= INTENT_INOUT
;
1767 strides
->as
->type
= AS_EXPLICIT
;
1768 strides
->as
->rank
= 1;
1769 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1770 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1771 gfc_set_sym_referenced (strides
);
1772 gfc_commit_symbol (strides
);
1775 /* Set return value to 0. */
1776 last_code
= gfc_get_code (EXEC_ASSIGN
);
1777 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1778 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1779 sub_ns
->code
= last_code
;
1781 /* Set: is_contiguous = .true. */
1782 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1783 last_code
= last_code
->next
;
1784 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1785 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1786 &gfc_current_locus
, true);
1788 /* Set: sizes(0) = 1. */
1789 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1790 last_code
= last_code
->next
;
1791 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1792 last_code
->expr1
->ref
= gfc_get_ref ();
1793 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1794 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1795 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1796 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1797 last_code
->expr1
->ref
->u
.ar
.start
[0]
1798 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1799 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1800 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1804 strides(idx) = _F._stride (array, dim=idx)
1805 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1806 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1810 iter
= gfc_get_iterator ();
1811 iter
->var
= gfc_lval_expr_from_sym (idx
);
1812 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1813 iter
->end
= gfc_copy_expr (rank
);
1814 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1815 last_code
->next
= gfc_get_code (EXEC_DO
);
1816 last_code
= last_code
->next
;
1817 last_code
->ext
.iterator
= iter
;
1818 last_code
->block
= gfc_get_code (EXEC_DO
);
1820 /* strides(idx) = _F._stride(array,dim=idx). */
1821 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1822 block
= last_code
->block
->next
;
1824 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1825 block
->expr1
->ref
= gfc_get_ref ();
1826 block
->expr1
->ref
->type
= REF_ARRAY
;
1827 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1828 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1829 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1830 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1831 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1833 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1834 gfc_current_locus
, 2,
1835 gfc_lval_expr_from_sym (array
),
1836 gfc_lval_expr_from_sym (idx
));
1838 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1839 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1840 block
= block
->next
;
1842 /* sizes(idx) = ... */
1843 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1844 block
->expr1
->ref
= gfc_get_ref ();
1845 block
->expr1
->ref
->type
= REF_ARRAY
;
1846 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1847 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1848 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1849 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1850 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1852 block
->expr2
= gfc_get_expr ();
1853 block
->expr2
->expr_type
= EXPR_OP
;
1854 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1855 block
->expr2
->where
= gfc_current_locus
;
1858 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1859 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1860 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1861 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1862 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1863 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1864 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1865 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1866 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1867 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1868 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1869 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1870 = gfc_lval_expr_from_sym (idx
);
1871 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1872 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1873 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1874 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1876 /* size(array, dim=idx, kind=index_kind). */
1877 block
->expr2
->value
.op
.op2
1878 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1879 gfc_current_locus
, 3,
1880 gfc_lval_expr_from_sym (array
),
1881 gfc_lval_expr_from_sym (idx
),
1882 gfc_get_int_expr (gfc_index_integer_kind
,
1884 gfc_index_integer_kind
));
1885 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1886 block
->expr2
->ts
= idx
->ts
;
1888 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1889 block
->next
= gfc_get_code (EXEC_IF
);
1890 block
= block
->next
;
1892 block
->block
= gfc_get_code (EXEC_IF
);
1893 block
= block
->block
;
1895 /* if condition: strides(idx) /= sizes(idx-1). */
1896 block
->expr1
= gfc_get_expr ();
1897 block
->expr1
->ts
.type
= BT_LOGICAL
;
1898 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1899 block
->expr1
->expr_type
= EXPR_OP
;
1900 block
->expr1
->where
= gfc_current_locus
;
1901 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1903 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1904 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1905 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1906 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1907 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1908 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1909 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1910 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1912 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1913 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1914 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1915 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1916 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1917 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1918 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1919 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1920 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1921 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1922 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1923 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1924 = gfc_lval_expr_from_sym (idx
);
1925 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1926 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1927 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1928 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1930 /* if body: is_contiguous = .false. */
1931 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1932 block
= block
->next
;
1933 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1934 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1935 &gfc_current_locus
, false);
1937 /* Obtain the size (number of elements) of "array" MINUS ONE,
1938 which is used in the scalarization. */
1939 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1940 nelem
->ts
.type
= BT_INTEGER
;
1941 nelem
->ts
.kind
= gfc_index_integer_kind
;
1942 nelem
->attr
.flavor
= FL_VARIABLE
;
1943 nelem
->attr
.artificial
= 1;
1944 gfc_set_sym_referenced (nelem
);
1945 gfc_commit_symbol (nelem
);
1947 /* nelem = sizes (rank) - 1. */
1948 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1949 last_code
= last_code
->next
;
1951 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1953 last_code
->expr2
= gfc_get_expr ();
1954 last_code
->expr2
->expr_type
= EXPR_OP
;
1955 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1956 last_code
->expr2
->value
.op
.op2
1957 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1958 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1959 last_code
->expr2
->where
= gfc_current_locus
;
1961 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1962 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1963 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1964 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1965 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1966 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1967 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1968 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1970 /* Call final subroutines. We now generate code like:
1972 integer, pointer :: ptr
1974 integer(c_intptr_t) :: i, addr
1976 select case (rank (array))
1978 ! If needed, the array is packed
1979 call final_rank3 (array)
1981 do i = 0, size (array)-1
1982 addr = transfer (c_loc (array), addr) + i * stride
1983 call c_f_pointer (transfer (addr, cptr), ptr)
1984 call elemental_final (ptr)
1988 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1990 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1992 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1993 ptr
->ts
.type
= BT_DERIVED
;
1994 ptr
->ts
.u
.derived
= derived
;
1995 ptr
->attr
.flavor
= FL_VARIABLE
;
1996 ptr
->attr
.pointer
= 1;
1997 ptr
->attr
.artificial
= 1;
1998 gfc_set_sym_referenced (ptr
);
1999 gfc_commit_symbol (ptr
);
2001 /* SELECT CASE (RANK (array)). */
2002 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2003 last_code
= last_code
->next
;
2004 last_code
->expr1
= gfc_copy_expr (rank
);
2007 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
2009 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2010 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2016 /* CASE (fini_rank). */
2019 block
->block
= gfc_get_code (EXEC_SELECT
);
2020 block
= block
->block
;
2024 block
= gfc_get_code (EXEC_SELECT
);
2025 last_code
->block
= block
;
2027 block
->ext
.block
.case_list
= gfc_get_case ();
2028 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2029 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2030 block
->ext
.block
.case_list
->low
2031 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2032 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2034 block
->ext
.block
.case_list
->low
2035 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2036 block
->ext
.block
.case_list
->high
2037 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2039 /* CALL fini_rank (array) - possibly with packing. */
2040 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2041 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2042 idx
, ptr
, nelem
, strides
,
2043 sizes
, idx2
, offset
, is_contiguous
,
2047 block
->next
= gfc_get_code (EXEC_CALL
);
2048 block
->next
->symtree
= fini
->proc_tree
;
2049 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2050 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2051 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2055 /* Elemental call - scalarized. */
2061 block
->block
= gfc_get_code (EXEC_SELECT
);
2062 block
= block
->block
;
2066 block
= gfc_get_code (EXEC_SELECT
);
2067 last_code
->block
= block
;
2069 block
->ext
.block
.case_list
= gfc_get_case ();
2072 iter
= gfc_get_iterator ();
2073 iter
->var
= gfc_lval_expr_from_sym (idx
);
2074 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2075 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2076 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2077 block
->next
= gfc_get_code (EXEC_DO
);
2078 block
= block
->next
;
2079 block
->ext
.iterator
= iter
;
2080 block
->block
= gfc_get_code (EXEC_DO
);
2082 /* Offset calculation. */
2083 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2084 byte_stride
, rank
, block
->block
,
2088 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2089 + offset, c_ptr), ptr). */
2091 = finalization_scalarizer (array
, ptr
,
2092 gfc_lval_expr_from_sym (offset
),
2094 block
= block
->next
;
2096 /* CALL final_elemental (array). */
2097 block
->next
= gfc_get_code (EXEC_CALL
);
2098 block
= block
->next
;
2099 block
->symtree
= fini_elem
->proc_tree
;
2100 block
->resolved_sym
= fini_elem
->proc_sym
;
2101 block
->ext
.actual
= gfc_get_actual_arglist ();
2102 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2106 /* Finalize and deallocate allocatable components. The same manual
2107 scalarization is used as above. */
2109 if (finalizable_comp
)
2112 gfc_code
*block
= NULL
;
2116 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2117 ptr
->ts
.type
= BT_DERIVED
;
2118 ptr
->ts
.u
.derived
= derived
;
2119 ptr
->attr
.flavor
= FL_VARIABLE
;
2120 ptr
->attr
.pointer
= 1;
2121 ptr
->attr
.artificial
= 1;
2122 gfc_set_sym_referenced (ptr
);
2123 gfc_commit_symbol (ptr
);
2126 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2127 stat
->attr
.flavor
= FL_VARIABLE
;
2128 stat
->attr
.artificial
= 1;
2129 stat
->ts
.type
= BT_INTEGER
;
2130 stat
->ts
.kind
= gfc_default_integer_kind
;
2131 gfc_set_sym_referenced (stat
);
2132 gfc_commit_symbol (stat
);
2135 iter
= gfc_get_iterator ();
2136 iter
->var
= gfc_lval_expr_from_sym (idx
);
2137 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2138 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2139 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2140 last_code
->next
= gfc_get_code (EXEC_DO
);
2141 last_code
= last_code
->next
;
2142 last_code
->ext
.iterator
= iter
;
2143 last_code
->block
= gfc_get_code (EXEC_DO
);
2145 /* Offset calculation. */
2146 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2147 byte_stride
, rank
, last_code
->block
,
2151 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2152 + idx * stride, c_ptr), ptr). */
2153 block
->next
= finalization_scalarizer (array
, ptr
,
2154 gfc_lval_expr_from_sym(offset
),
2156 block
= block
->next
;
2158 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2160 if (comp
== derived
->components
&& derived
->attr
.extension
2161 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2164 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2165 stat
, fini_coarray
, &block
, sub_ns
);
2166 if (!last_code
->block
->next
)
2167 last_code
->block
->next
= block
;
2172 /* Call the finalizer of the ancestor. */
2173 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2175 last_code
->next
= gfc_get_code (EXEC_CALL
);
2176 last_code
= last_code
->next
;
2177 last_code
->symtree
= ancestor_wrapper
->symtree
;
2178 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2180 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2181 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2182 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2183 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2184 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2185 last_code
->ext
.actual
->next
->next
->expr
2186 = gfc_lval_expr_from_sym (fini_coarray
);
2189 gfc_free_expr (rank
);
2190 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2191 vtab_final
->ts
.interface
= final
;
2196 /* Add procedure pointers for all type-bound procedures to a vtab. */
2199 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2201 gfc_symbol
* super_type
;
2203 super_type
= gfc_get_derived_super_type (derived
);
2205 if (super_type
&& (super_type
!= derived
))
2207 /* Make sure that the PPCs appear in the same order as in the parent. */
2208 copy_vtab_proc_comps (super_type
, vtype
);
2209 /* Only needed to get the PPC initializers right. */
2210 add_procs_to_declared_vtab (super_type
, vtype
);
2213 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2214 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2216 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2217 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2221 /* Find or generate the symbol for a derived type's vtab. */
2224 gfc_find_derived_vtab (gfc_symbol
*derived
)
2227 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2228 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2229 gfc_gsymbol
*gsym
= NULL
;
2230 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2232 if (derived
->attr
.pdt_template
)
2235 /* Find the top-level namespace. */
2236 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2240 /* If the type is a class container, use the underlying derived type. */
2241 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2242 derived
= gfc_get_derived_super_type (derived
);
2244 /* Find the gsymbol for the module of use associated derived types. */
2245 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2246 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2247 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2251 /* Work in the gsymbol namespace if the top-level namespace is a module.
2252 This ensures that the vtable is unique, which is required since we use
2253 its address in SELECT TYPE. */
2254 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2255 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2260 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2263 get_unique_hashed_string (tname
, derived
);
2264 name
= xasprintf ("__vtab_%s", tname
);
2266 /* Look for the vtab symbol in various namespaces. */
2267 if (gsym
&& gsym
->ns
)
2269 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2274 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2276 gfc_find_symbol (name
, ns
, 0, &vtab
);
2278 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2282 gfc_get_symbol (name
, ns
, &vtab
);
2283 vtab
->ts
.type
= BT_DERIVED
;
2284 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2285 &gfc_current_locus
))
2287 vtab
->attr
.target
= 1;
2288 vtab
->attr
.save
= SAVE_IMPLICIT
;
2289 vtab
->attr
.vtab
= 1;
2290 vtab
->attr
.access
= ACCESS_PUBLIC
;
2291 gfc_set_sym_referenced (vtab
);
2292 name
= xasprintf ("__vtype_%s", tname
);
2294 gfc_find_symbol (name
, ns
, 0, &vtype
);
2298 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2301 /* Is this a derived type with recursive allocatable
2303 c
= (derived
->attr
.unlimited_polymorphic
2304 || derived
->attr
.abstract
) ?
2305 NULL
: derived
->components
;
2306 for (; c
; c
= c
->next
)
2307 if (c
->ts
.type
== BT_DERIVED
2308 && c
->ts
.u
.derived
== derived
)
2314 gfc_get_symbol (name
, ns
, &vtype
);
2315 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2316 &gfc_current_locus
))
2318 vtype
->attr
.access
= ACCESS_PUBLIC
;
2319 vtype
->attr
.vtype
= 1;
2320 gfc_set_sym_referenced (vtype
);
2322 /* Add component '_hash'. */
2323 if (!gfc_add_component (vtype
, "_hash", &c
))
2325 c
->ts
.type
= BT_INTEGER
;
2327 c
->attr
.access
= ACCESS_PRIVATE
;
2328 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2329 NULL
, derived
->hash_value
);
2331 /* Add component '_size'. */
2332 if (!gfc_add_component (vtype
, "_size", &c
))
2334 c
->ts
.type
= BT_INTEGER
;
2335 c
->ts
.kind
= gfc_size_kind
;
2336 c
->attr
.access
= ACCESS_PRIVATE
;
2337 /* Remember the derived type in ts.u.derived,
2338 so that the correct initializer can be set later on
2339 (in gfc_conv_structure). */
2340 c
->ts
.u
.derived
= derived
;
2341 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2344 /* Add component _extends. */
2345 if (!gfc_add_component (vtype
, "_extends", &c
))
2347 c
->attr
.pointer
= 1;
2348 c
->attr
.access
= ACCESS_PRIVATE
;
2349 if (!derived
->attr
.unlimited_polymorphic
)
2350 parent
= gfc_get_derived_super_type (derived
);
2356 parent_vtab
= gfc_find_derived_vtab (parent
);
2357 c
->ts
.type
= BT_DERIVED
;
2358 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2359 c
->initializer
= gfc_get_expr ();
2360 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2361 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2362 0, &c
->initializer
->symtree
);
2366 c
->ts
.type
= BT_DERIVED
;
2367 c
->ts
.u
.derived
= vtype
;
2368 c
->initializer
= gfc_get_null_expr (NULL
);
2371 if (!derived
->attr
.unlimited_polymorphic
2372 && derived
->components
== NULL
2373 && !derived
->attr
.zero_comp
)
2375 /* At this point an error must have occurred.
2376 Prevent further errors on the vtype components. */
2381 /* Add component _def_init. */
2382 if (!gfc_add_component (vtype
, "_def_init", &c
))
2384 c
->attr
.pointer
= 1;
2385 c
->attr
.artificial
= 1;
2386 c
->attr
.access
= ACCESS_PRIVATE
;
2387 c
->ts
.type
= BT_DERIVED
;
2388 c
->ts
.u
.derived
= derived
;
2389 if (derived
->attr
.unlimited_polymorphic
2390 || derived
->attr
.abstract
)
2391 c
->initializer
= gfc_get_null_expr (NULL
);
2394 /* Construct default initialization variable. */
2395 name
= xasprintf ("__def_init_%s", tname
);
2396 gfc_get_symbol (name
, ns
, &def_init
);
2397 def_init
->attr
.target
= 1;
2398 def_init
->attr
.artificial
= 1;
2399 def_init
->attr
.save
= SAVE_IMPLICIT
;
2400 def_init
->attr
.access
= ACCESS_PUBLIC
;
2401 def_init
->attr
.flavor
= FL_VARIABLE
;
2402 gfc_set_sym_referenced (def_init
);
2403 def_init
->ts
.type
= BT_DERIVED
;
2404 def_init
->ts
.u
.derived
= derived
;
2405 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2407 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2410 /* Add component _copy. */
2411 if (!gfc_add_component (vtype
, "_copy", &c
))
2413 c
->attr
.proc_pointer
= 1;
2414 c
->attr
.access
= ACCESS_PRIVATE
;
2415 c
->tb
= XCNEW (gfc_typebound_proc
);
2417 if (derived
->attr
.unlimited_polymorphic
2418 || derived
->attr
.abstract
)
2419 c
->initializer
= gfc_get_null_expr (NULL
);
2422 /* Set up namespace. */
2423 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2424 sub_ns
->sibling
= ns
->contained
;
2425 ns
->contained
= sub_ns
;
2426 sub_ns
->resolved
= 1;
2427 /* Set up procedure symbol. */
2428 name
= xasprintf ("__copy_%s", tname
);
2429 gfc_get_symbol (name
, sub_ns
, ©
);
2430 sub_ns
->proc_name
= copy
;
2431 copy
->attr
.flavor
= FL_PROCEDURE
;
2432 copy
->attr
.subroutine
= 1;
2433 copy
->attr
.pure
= 1;
2434 copy
->attr
.artificial
= 1;
2435 copy
->attr
.if_source
= IFSRC_DECL
;
2436 /* This is elemental so that arrays are automatically
2437 treated correctly by the scalarizer. */
2438 copy
->attr
.elemental
= 1;
2439 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2440 copy
->module
= ns
->proc_name
->name
;
2441 gfc_set_sym_referenced (copy
);
2442 /* Set up formal arguments. */
2443 gfc_get_symbol ("src", sub_ns
, &src
);
2444 src
->ts
.type
= BT_DERIVED
;
2445 src
->ts
.u
.derived
= derived
;
2446 src
->attr
.flavor
= FL_VARIABLE
;
2447 src
->attr
.dummy
= 1;
2448 src
->attr
.artificial
= 1;
2449 src
->attr
.intent
= INTENT_IN
;
2450 gfc_set_sym_referenced (src
);
2451 copy
->formal
= gfc_get_formal_arglist ();
2452 copy
->formal
->sym
= src
;
2453 gfc_get_symbol ("dst", sub_ns
, &dst
);
2454 dst
->ts
.type
= BT_DERIVED
;
2455 dst
->ts
.u
.derived
= derived
;
2456 dst
->attr
.flavor
= FL_VARIABLE
;
2457 dst
->attr
.dummy
= 1;
2458 dst
->attr
.artificial
= 1;
2459 dst
->attr
.intent
= INTENT_INOUT
;
2460 gfc_set_sym_referenced (dst
);
2461 copy
->formal
->next
= gfc_get_formal_arglist ();
2462 copy
->formal
->next
->sym
= dst
;
2464 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2465 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2466 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2467 /* Set initializer. */
2468 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2469 c
->ts
.interface
= copy
;
2472 /* Add component _final, which contains a procedure pointer to
2473 a wrapper which handles both the freeing of allocatable
2474 components and the calls to finalization subroutines.
2475 Note: The actual wrapper function can only be generated
2476 at resolution time. */
2477 if (!gfc_add_component (vtype
, "_final", &c
))
2479 c
->attr
.proc_pointer
= 1;
2480 c
->attr
.access
= ACCESS_PRIVATE
;
2481 c
->attr
.artificial
= 1;
2482 c
->tb
= XCNEW (gfc_typebound_proc
);
2484 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2486 /* Add component _deallocate. */
2487 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2489 c
->attr
.proc_pointer
= 1;
2490 c
->attr
.access
= ACCESS_PRIVATE
;
2491 c
->tb
= XCNEW (gfc_typebound_proc
);
2493 if (derived
->attr
.unlimited_polymorphic
2494 || derived
->attr
.abstract
2496 c
->initializer
= gfc_get_null_expr (NULL
);
2499 /* Set up namespace. */
2500 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2502 sub_ns
->sibling
= ns
->contained
;
2503 ns
->contained
= sub_ns
;
2504 sub_ns
->resolved
= 1;
2505 /* Set up procedure symbol. */
2506 name
= xasprintf ("__deallocate_%s", tname
);
2507 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2508 sub_ns
->proc_name
= dealloc
;
2509 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2510 dealloc
->attr
.subroutine
= 1;
2511 dealloc
->attr
.pure
= 1;
2512 dealloc
->attr
.artificial
= 1;
2513 dealloc
->attr
.if_source
= IFSRC_DECL
;
2515 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2516 dealloc
->module
= ns
->proc_name
->name
;
2517 gfc_set_sym_referenced (dealloc
);
2518 /* Set up formal argument. */
2519 gfc_get_symbol ("arg", sub_ns
, &arg
);
2520 arg
->ts
.type
= BT_DERIVED
;
2521 arg
->ts
.u
.derived
= derived
;
2522 arg
->attr
.flavor
= FL_VARIABLE
;
2523 arg
->attr
.dummy
= 1;
2524 arg
->attr
.artificial
= 1;
2525 arg
->attr
.intent
= INTENT_INOUT
;
2526 arg
->attr
.dimension
= 1;
2527 arg
->attr
.allocatable
= 1;
2528 arg
->as
= gfc_get_array_spec();
2529 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2531 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2533 gfc_set_sym_referenced (arg
);
2534 dealloc
->formal
= gfc_get_formal_arglist ();
2535 dealloc
->formal
->sym
= arg
;
2537 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2538 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2539 sub_ns
->code
->ext
.alloc
.list
->expr
2540 = gfc_lval_expr_from_sym (arg
);
2541 /* Set initializer. */
2542 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2543 c
->ts
.interface
= dealloc
;
2546 /* Add procedure pointers for type-bound procedures. */
2547 if (!derived
->attr
.unlimited_polymorphic
)
2548 add_procs_to_declared_vtab (derived
, vtype
);
2552 vtab
->ts
.u
.derived
= vtype
;
2553 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2561 /* It is unexpected to have some symbols added at resolution or code
2562 generation time. We commit the changes in order to keep a clean state. */
2565 gfc_commit_symbol (vtab
);
2567 gfc_commit_symbol (vtype
);
2569 gfc_commit_symbol (def_init
);
2571 gfc_commit_symbol (copy
);
2573 gfc_commit_symbol (src
);
2575 gfc_commit_symbol (dst
);
2577 gfc_commit_symbol (dealloc
);
2579 gfc_commit_symbol (arg
);
2582 gfc_undo_symbols ();
2588 /* Check if a derived type is finalizable. That is the case if it
2589 (1) has a FINAL subroutine or
2590 (2) has a nonpointer nonallocatable component of finalizable type.
2591 If it is finalizable, return an expression containing the
2592 finalization wrapper. */
2595 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2600 /* (1) Check for FINAL subroutines. */
2601 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2604 /* (2) Check for components of finalizable type. */
2605 for (c
= derived
->components
; c
; c
= c
->next
)
2606 if (c
->ts
.type
== BT_DERIVED
2607 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2608 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2614 /* Make sure vtab is generated. */
2615 vtab
= gfc_find_derived_vtab (derived
);
2618 /* Return finalizer expression. */
2619 gfc_component
*final
;
2620 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2621 gcc_assert (strcmp (final
->name
, "_final") == 0);
2622 gcc_assert (final
->initializer
2623 && final
->initializer
->expr_type
!= EXPR_NULL
);
2624 *final_expr
= final
->initializer
;
2630 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2631 needed to support unlimited polymorphism. */
2634 find_intrinsic_vtab (gfc_typespec
*ts
)
2637 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2638 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2640 /* Find the top-level namespace. */
2641 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2647 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2650 /* Encode all types as TYPENAME_KIND_ including especially character
2651 arrays, whose length is now consistently stored in the _len component
2652 of the class-variable. */
2653 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2654 name
= xasprintf ("__vtab_%s", tname
);
2656 /* Look for the vtab symbol in the top-level namespace only. */
2657 gfc_find_symbol (name
, ns
, 0, &vtab
);
2661 gfc_get_symbol (name
, ns
, &vtab
);
2662 vtab
->ts
.type
= BT_DERIVED
;
2663 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2664 &gfc_current_locus
))
2666 vtab
->attr
.target
= 1;
2667 vtab
->attr
.save
= SAVE_IMPLICIT
;
2668 vtab
->attr
.vtab
= 1;
2669 vtab
->attr
.access
= ACCESS_PUBLIC
;
2670 gfc_set_sym_referenced (vtab
);
2671 name
= xasprintf ("__vtype_%s", tname
);
2673 gfc_find_symbol (name
, ns
, 0, &vtype
);
2678 gfc_namespace
*sub_ns
;
2679 gfc_namespace
*contained
;
2683 gfc_get_symbol (name
, ns
, &vtype
);
2684 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2685 &gfc_current_locus
))
2687 vtype
->attr
.access
= ACCESS_PUBLIC
;
2688 vtype
->attr
.vtype
= 1;
2689 gfc_set_sym_referenced (vtype
);
2691 /* Add component '_hash'. */
2692 if (!gfc_add_component (vtype
, "_hash", &c
))
2694 c
->ts
.type
= BT_INTEGER
;
2696 c
->attr
.access
= ACCESS_PRIVATE
;
2697 hash
= gfc_intrinsic_hash_value (ts
);
2698 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2701 /* Add component '_size'. */
2702 if (!gfc_add_component (vtype
, "_size", &c
))
2704 c
->ts
.type
= BT_INTEGER
;
2705 c
->ts
.kind
= gfc_size_kind
;
2706 c
->attr
.access
= ACCESS_PRIVATE
;
2708 /* Build a minimal expression to make use of
2709 target-memory.c/gfc_element_size for 'size'. Special handling
2710 for character arrays, that are not constant sized: to support
2711 len (str) * kind, only the kind information is stored in the
2713 e
= gfc_get_expr ();
2715 e
->expr_type
= EXPR_VARIABLE
;
2716 if (ts
->type
== BT_CHARACTER
)
2719 gfc_element_size (e
, &e_size
);
2720 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2725 /* Add component _extends. */
2726 if (!gfc_add_component (vtype
, "_extends", &c
))
2728 c
->attr
.pointer
= 1;
2729 c
->attr
.access
= ACCESS_PRIVATE
;
2730 c
->ts
.type
= BT_VOID
;
2731 c
->initializer
= gfc_get_null_expr (NULL
);
2733 /* Add component _def_init. */
2734 if (!gfc_add_component (vtype
, "_def_init", &c
))
2736 c
->attr
.pointer
= 1;
2737 c
->attr
.access
= ACCESS_PRIVATE
;
2738 c
->ts
.type
= BT_VOID
;
2739 c
->initializer
= gfc_get_null_expr (NULL
);
2741 /* Add component _copy. */
2742 if (!gfc_add_component (vtype
, "_copy", &c
))
2744 c
->attr
.proc_pointer
= 1;
2745 c
->attr
.access
= ACCESS_PRIVATE
;
2746 c
->tb
= XCNEW (gfc_typebound_proc
);
2749 if (ts
->type
!= BT_CHARACTER
)
2750 name
= xasprintf ("__copy_%s", tname
);
2753 /* __copy is always the same for characters.
2754 Check to see if copy function already exists. */
2755 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2756 contained
= ns
->contained
;
2757 for (; contained
; contained
= contained
->sibling
)
2758 if (contained
->proc_name
2759 && strcmp (name
, contained
->proc_name
->name
) == 0)
2761 copy
= contained
->proc_name
;
2766 /* Set up namespace. */
2767 sub_ns
= gfc_get_namespace (ns
, 0);
2768 sub_ns
->sibling
= ns
->contained
;
2769 ns
->contained
= sub_ns
;
2770 sub_ns
->resolved
= 1;
2771 /* Set up procedure symbol. */
2772 gfc_get_symbol (name
, sub_ns
, ©
);
2773 sub_ns
->proc_name
= copy
;
2774 copy
->attr
.flavor
= FL_PROCEDURE
;
2775 copy
->attr
.subroutine
= 1;
2776 copy
->attr
.pure
= 1;
2777 copy
->attr
.if_source
= IFSRC_DECL
;
2778 /* This is elemental so that arrays are automatically
2779 treated correctly by the scalarizer. */
2780 copy
->attr
.elemental
= 1;
2781 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2782 copy
->module
= ns
->proc_name
->name
;
2783 gfc_set_sym_referenced (copy
);
2784 /* Set up formal arguments. */
2785 gfc_get_symbol ("src", sub_ns
, &src
);
2786 src
->ts
.type
= ts
->type
;
2787 src
->ts
.kind
= ts
->kind
;
2788 src
->attr
.flavor
= FL_VARIABLE
;
2789 src
->attr
.dummy
= 1;
2790 src
->attr
.intent
= INTENT_IN
;
2791 gfc_set_sym_referenced (src
);
2792 copy
->formal
= gfc_get_formal_arglist ();
2793 copy
->formal
->sym
= src
;
2794 gfc_get_symbol ("dst", sub_ns
, &dst
);
2795 dst
->ts
.type
= ts
->type
;
2796 dst
->ts
.kind
= ts
->kind
;
2797 dst
->attr
.flavor
= FL_VARIABLE
;
2798 dst
->attr
.dummy
= 1;
2799 dst
->attr
.intent
= INTENT_INOUT
;
2800 gfc_set_sym_referenced (dst
);
2801 copy
->formal
->next
= gfc_get_formal_arglist ();
2802 copy
->formal
->next
->sym
= dst
;
2804 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2805 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2806 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2808 /* Set initializer. */
2809 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2810 c
->ts
.interface
= copy
;
2812 /* Add component _final. */
2813 if (!gfc_add_component (vtype
, "_final", &c
))
2815 c
->attr
.proc_pointer
= 1;
2816 c
->attr
.access
= ACCESS_PRIVATE
;
2817 c
->attr
.artificial
= 1;
2818 c
->tb
= XCNEW (gfc_typebound_proc
);
2820 c
->initializer
= gfc_get_null_expr (NULL
);
2822 vtab
->ts
.u
.derived
= vtype
;
2823 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2831 /* It is unexpected to have some symbols added at resolution or code
2832 generation time. We commit the changes in order to keep a clean state. */
2835 gfc_commit_symbol (vtab
);
2837 gfc_commit_symbol (vtype
);
2839 gfc_commit_symbol (copy
);
2841 gfc_commit_symbol (src
);
2843 gfc_commit_symbol (dst
);
2846 gfc_undo_symbols ();
2852 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2855 gfc_find_vtab (gfc_typespec
*ts
)
2862 return gfc_find_derived_vtab (ts
->u
.derived
);
2864 if (ts
->u
.derived
->components
&& ts
->u
.derived
->components
->ts
.u
.derived
)
2865 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2869 return find_intrinsic_vtab (ts
);
2874 /* General worker function to find either a type-bound procedure or a
2875 type-bound user operator. */
2878 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2879 const char* name
, bool noaccess
, bool uop
,
2885 /* Set default to failure. */
2889 if (derived
->f2k_derived
)
2890 /* Set correct symbol-root. */
2891 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2892 : derived
->f2k_derived
->tb_sym_root
);
2896 /* Try to find it in the current type's namespace. */
2897 res
= gfc_find_symtree (root
, name
);
2898 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2904 if (!noaccess
&& derived
->attr
.use_assoc
2905 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2908 gfc_error ("%qs of %qs is PRIVATE at %L",
2909 name
, derived
->name
, where
);
2917 /* Otherwise, recurse on parent type if derived is an extension. */
2918 if (derived
->attr
.extension
)
2920 gfc_symbol
* super_type
;
2921 super_type
= gfc_get_derived_super_type (derived
);
2922 gcc_assert (super_type
);
2924 return find_typebound_proc_uop (super_type
, t
, name
,
2925 noaccess
, uop
, where
);
2928 /* Nothing found. */
2933 /* Find a type-bound procedure or user operator by name for a derived-type
2934 (looking recursively through the super-types). */
2937 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2938 const char* name
, bool noaccess
, locus
* where
)
2940 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2944 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2945 const char* name
, bool noaccess
, locus
* where
)
2947 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2951 /* Find a type-bound intrinsic operator looking recursively through the
2952 super-type hierarchy. */
2955 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2956 gfc_intrinsic_op op
, bool noaccess
,
2959 gfc_typebound_proc
* res
;
2961 /* Set default to failure. */
2965 /* Try to find it in the current type's namespace. */
2966 if (derived
->f2k_derived
)
2967 res
= derived
->f2k_derived
->tb_op
[op
];
2972 if (res
&& !res
->error
)
2978 if (!noaccess
&& derived
->attr
.use_assoc
2979 && res
->access
== ACCESS_PRIVATE
)
2982 gfc_error ("%qs of %qs is PRIVATE at %L",
2983 gfc_op2string (op
), derived
->name
, where
);
2991 /* Otherwise, recurse on parent type if derived is an extension. */
2992 if (derived
->attr
.extension
)
2994 gfc_symbol
* super_type
;
2995 super_type
= gfc_get_derived_super_type (derived
);
2996 gcc_assert (super_type
);
2998 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3002 /* Nothing found. */
3007 /* Get a typebound-procedure symtree or create and insert it if not yet
3008 present. This is like a very simplified version of gfc_get_sym_tree for
3009 tbp-symtrees rather than regular ones. */
3012 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3014 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3015 return result
? result
: gfc_new_symtree (root
, name
);