1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2025 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.cc -- 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.
52 * _deallocate: A procedure pointer to a deallocation procedure; nonnull
53 only for a recursive derived type.
55 After these follow procedure pointer components for the specific
56 type-bound procedures. */
61 #include "coretypes.h"
63 #include "constructor.h"
64 #include "target-memory.h"
66 /* Inserts a derived type component reference in a data reference chain.
67 TS: base type of the ref chain so far, in which we will pick the component
68 REF: the address of the GFC_REF pointer to update
69 NAME: name of the component to insert
70 Note that component insertion makes sense only if we are at the end of
71 the chain (*REF == NULL) or if we are adding a missing "_data" component
72 to access the actual contents of a class object. */
75 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
80 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
82 gfc_find_component (ts
->u
.derived
, name
, true, true, &new_ref
);
84 gfc_get_errors (&wcnt
, &ecnt
);
85 if (ecnt
> 0 && !new_ref
)
87 gcc_assert (new_ref
->u
.c
.component
);
90 new_ref
= new_ref
->next
;
97 /* We need to update the base type in the trailing reference chain to
98 that of the new component. */
100 gcc_assert (strcmp (name
, "_data") == 0);
102 if (new_ref
->next
->type
== REF_COMPONENT
)
103 next
= new_ref
->next
;
104 else if (new_ref
->next
->type
== REF_ARRAY
105 && new_ref
->next
->next
106 && new_ref
->next
->next
->type
== REF_COMPONENT
)
107 next
= new_ref
->next
->next
;
111 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
112 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
113 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
121 /* Tells whether we need to add a "_data" reference to access REF subobject
122 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
123 object accessed by REF is a variable; in other words it is a full object,
127 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
129 /* Only class containers may need the "_data" reference. */
130 if (ts
->type
!= BT_CLASS
)
133 /* Accessing a class container with an array reference is certainly wrong. */
134 if (ref
->type
!= REF_COMPONENT
)
137 /* Accessing the class container's fields is fine. */
138 if (ref
->u
.c
.component
->name
[0] == '_')
141 /* At this point we have a class container with a non class container's field
142 component reference. We don't want to add the "_data" component if we are
143 at the first reference and the symbol's type is an extended derived type.
144 In that case, conv_parent_component_references will do the right thing so
145 it is not absolutely necessary. Omitting it prevents a regression (see
146 class_41.f03) in the interface mapping mechanism. When evaluating string
147 lengths depending on dummy arguments, we create a fake symbol with a type
148 equal to that of the dummy type. However, because of type extension,
149 the backend type (corresponding to the actual argument) can have a
150 different (extended) type. Adding the "_data" component explicitly, using
151 the base type, confuses the gfc_conv_component_ref code which deals with
152 the extended type. */
153 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
156 /* We have a class container with a non class container's field component
157 reference that doesn't fall into the above. */
162 /* Browse through a data reference chain and add the missing "_data" references
163 when a subobject of a class object is accessed without it.
164 Note that it doesn't add the "_data" reference when the class container
165 is the last element in the reference chain. */
168 gfc_fix_class_refs (gfc_expr
*e
)
173 if ((e
->expr_type
!= EXPR_VARIABLE
174 && e
->expr_type
!= EXPR_FUNCTION
)
175 || (e
->expr_type
== EXPR_FUNCTION
176 && e
->value
.function
.isym
!= NULL
))
179 if (e
->expr_type
== EXPR_VARIABLE
)
180 ts
= &e
->symtree
->n
.sym
->ts
;
185 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
186 if (e
->value
.function
.esym
!= NULL
)
187 func
= e
->value
.function
.esym
;
189 func
= e
->symtree
->n
.sym
;
191 if (func
->result
!= NULL
)
192 ts
= &func
->result
->ts
;
197 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
199 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
200 insert_component_ref (ts
, ref
, "_data");
202 if ((*ref
)->type
== REF_COMPONENT
)
203 ts
= &(*ref
)->u
.c
.component
->ts
;
208 /* Insert a reference to the component of the given name.
209 Only to be used with CLASS containers and vtables. */
212 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
215 gfc_ref
**tail
= &(e
->ref
);
216 gfc_ref
*ref
, *next
= NULL
;
217 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
218 while (*tail
!= NULL
)
220 if ((*tail
)->type
== REF_COMPONENT
)
222 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
224 && (*tail
)->next
->type
== REF_ARRAY
225 && (*tail
)->next
->next
== NULL
)
227 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
229 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
231 tail
= &((*tail
)->next
);
233 if (derived
&& derived
->components
&& derived
->components
->next
&&
234 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
235 derived
->components
->next
->ts
.u
.derived
== NULL
)
237 /* Fix up missing vtype. */
238 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
240 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
242 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
245 /* Avoid losing memory. */
246 gfc_free_ref_list (*tail
);
247 c
= gfc_find_component (derived
, name
, true, true, tail
);
250 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
259 /* This is used to add both the _data component reference and an array
260 reference to class expressions. Used in translation of intrinsic
261 array inquiry functions. */
264 gfc_add_class_array_ref (gfc_expr
*e
)
266 int rank
= CLASS_DATA (e
)->as
->rank
;
267 int corank
= CLASS_DATA (e
)->as
->corank
;
268 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
270 gfc_add_data_component (e
);
273 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
276 if (ref
->type
!= REF_ARRAY
)
278 ref
->next
= gfc_get_ref ();
280 ref
->type
= REF_ARRAY
;
281 ref
->u
.ar
.type
= AR_FULL
;
287 /* Unfortunately, class array expressions can appear in various conditions;
288 with and without both _data component and an arrayspec. This function
289 deals with that variability. The previous reference to 'ref' is to a
293 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
295 bool no_data
= false;
296 bool with_data
= false;
298 /* An array reference with no _data component. */
299 if (ref
&& ref
->type
== REF_ARRAY
301 && ref
->u
.ar
.type
!= AR_ELEMENT
)
304 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
308 /* Cover cases where _data appears, with or without an array ref. */
309 if (ref
&& ref
->type
== REF_COMPONENT
310 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
318 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
319 && ref
->type
== REF_COMPONENT
320 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
324 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
328 return no_data
|| with_data
;
332 /* Returns true if the expression contains a reference to a class
333 array. Notice that class array elements return false. */
336 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
346 /* Is this a class array object? ie. Is the symbol of type class? */
348 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
349 && CLASS_DATA (e
->symtree
->n
.sym
)
350 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
351 && class_array_ref_detected (e
->ref
, full_array
))
354 /* Or is this a class array component reference? */
355 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
357 if (ref
->type
== REF_COMPONENT
358 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
359 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
360 && class_array_ref_detected (ref
->next
, full_array
))
368 /* Returns true if the expression is a reference to a class
369 scalar. This function is necessary because such expressions
370 can be dressed with a reference to the _data component and so
371 have a type other than BT_CLASS. */
374 gfc_is_class_scalar_expr (gfc_expr
*e
)
381 /* Is this a class object? */
382 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
383 && CLASS_DATA (e
->symtree
->n
.sym
)
384 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
386 || (e
->ref
->type
== REF_COMPONENT
387 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
388 && (e
->ref
->next
== NULL
389 || (e
->ref
->next
->type
== REF_ARRAY
390 && e
->ref
->next
->u
.ar
.codimen
> 0
391 && e
->ref
->next
->u
.ar
.dimen
== 0
392 && e
->ref
->next
->next
== NULL
)))))
395 /* Or is the final reference BT_CLASS or _data? */
396 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
398 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->ts
.type
== BT_CLASS
399 && CLASS_DATA (ref
->u
.c
.component
)
400 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
401 && (ref
->next
== NULL
402 || (ref
->next
->type
== REF_COMPONENT
403 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
404 && (ref
->next
->next
== NULL
405 || (ref
->next
->next
->type
== REF_ARRAY
406 && ref
->next
->next
->u
.ar
.codimen
> 0
407 && ref
->next
->next
->u
.ar
.dimen
== 0
408 && ref
->next
->next
->next
== NULL
)))))
416 /* Tells whether the expression E is a reference to a (scalar) class container.
417 Scalar because array class containers usually have an array reference after
418 them, and gfc_fix_class_refs will add the missing "_data" component reference
422 gfc_is_class_container_ref (gfc_expr
*e
)
427 if (e
->expr_type
!= EXPR_VARIABLE
)
428 return e
->ts
.type
== BT_CLASS
;
430 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
435 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
437 if (ref
->type
!= REF_COMPONENT
)
439 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
449 /* Build an initializer for CLASS pointers,
450 initializing the _data component to the init_expr (or NULL) and the _vptr
451 component to the corresponding type (or the declared type, given by ts). */
454 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
458 gfc_symbol
*vtab
= NULL
;
460 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
461 vtab
= gfc_find_vtab (&init_expr
->ts
);
463 vtab
= gfc_find_vtab (ts
);
465 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
466 &ts
->u
.derived
->declared_at
);
469 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
471 gfc_constructor
*ctor
= gfc_constructor_get();
472 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
473 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
474 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
475 ctor
->expr
= gfc_copy_expr (init_expr
);
477 ctor
->expr
= gfc_get_null_expr (NULL
);
478 gfc_constructor_append (&init
->value
.constructor
, ctor
);
485 /* Create a unique string identifier for a derived type, composed of its name
486 and module name. This is used to construct unique names for the class
487 containers and vtab symbols. */
490 get_unique_type_string (gfc_symbol
*derived
)
495 if (derived
->attr
.unlimited_polymorphic
)
498 dt_name
= gfc_dt_upper_string (derived
->name
);
499 len
= strlen (dt_name
) + 2;
500 if (derived
->attr
.unlimited_polymorphic
)
502 string
= XNEWVEC (char, len
);
503 sprintf (string
, "_%s", dt_name
);
505 else if (derived
->module
)
507 string
= XNEWVEC (char, strlen (derived
->module
) + len
);
508 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
510 else if (derived
->ns
->proc_name
)
512 string
= XNEWVEC (char, strlen (derived
->ns
->proc_name
->name
) + len
);
513 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
517 string
= XNEWVEC (char, len
);
518 sprintf (string
, "_%s", dt_name
);
524 /* A relative of 'get_unique_type_string' which makes sure the generated
525 string will not be too long (replacing it by a hash string if needed). */
528 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
530 /* Provide sufficient space to hold "symbol.symbol_symbol". */
532 tmp
= get_unique_type_string (derived
);
533 /* If string is too long, use hash value in hex representation (allow for
534 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
535 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
536 where %d is the (co)rank which can be up to n = 15. */
537 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
539 int h
= gfc_hash_value (derived
);
540 sprintf (string
, "%X", h
);
543 strcpy (string
, tmp
);
548 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
551 gfc_hash_value (gfc_symbol
*sym
)
553 unsigned int hash
= 0;
554 /* Provide sufficient space to hold "symbol.symbol_symbol". */
558 c
= get_unique_type_string (sym
);
561 for (i
= 0; i
< len
; i
++)
562 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
565 /* Return the hash but take the modulus for the sake of module read,
566 even though this slightly increases the chance of collision. */
567 return (hash
% 100000000);
571 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
574 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
576 unsigned int hash
= 0;
577 const char *c
= gfc_typename (ts
, true);
582 for (i
= 0; i
< len
; i
++)
583 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
585 /* Return the hash but take the modulus for the sake of module read,
586 even though this slightly increases the chance of collision. */
587 return (hash
% 100000000);
591 /* Get the _len component from a class/derived object storing a string.
592 For unlimited polymorphic entities a ref to the _data component is available
593 while a ref to the _len component is needed. This routine traverese the
594 ref-chain and strips the last ref to a _data from it replacing it with a
595 ref to the _len component. */
598 gfc_get_len_component (gfc_expr
*e
, int k
)
601 gfc_ref
*ref
, **last
;
603 ptr
= gfc_copy_expr (e
);
605 /* We need to remove the last _data component ref from ptr. */
611 && ref
->type
== REF_COMPONENT
612 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
614 gfc_free_ref_list (ref
);
621 /* And replace if with a ref to the _len component. */
622 gfc_add_len_component (ptr
);
623 if (k
!= ptr
->ts
.kind
)
627 ts
.type
= BT_INTEGER
;
629 gfc_convert_type_warn (ptr
, &ts
, 2, 0);
635 /* Build a polymorphic CLASS entity, using the symbol that comes from
636 build_sym. A CLASS entity is represented by an encapsulating type,
637 which contains the declared type as '_data' component, plus a pointer
638 component '_vptr' which determines the dynamic type. When this CLASS
639 entity is unlimited polymorphic, then also add a component '_len' to
640 store the length of string when that is stored in it. */
644 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
647 char tname
[GFC_MAX_SYMBOL_LEN
+1];
649 gfc_typespec
*orig_ts
= ts
;
658 /* We cannot build the class container now. */
659 if (attr
->class_ok
&& (!ts
->u
.derived
|| !ts
->u
.derived
->components
))
662 /* Class container has already been built with same name. */
664 && ts
->u
.derived
->components
->attr
.dimension
>= attr
->dimension
665 && ts
->u
.derived
->components
->attr
.codimension
>= attr
->codimension
666 && ts
->u
.derived
->components
->attr
.class_pointer
>= attr
->pointer
667 && ts
->u
.derived
->components
->attr
.allocatable
>= attr
->allocatable
)
671 attr
->dimension
|= ts
->u
.derived
->components
->attr
.dimension
;
672 attr
->codimension
|= ts
->u
.derived
->components
->attr
.codimension
;
673 attr
->pointer
|= ts
->u
.derived
->components
->attr
.class_pointer
;
674 attr
->allocatable
|= ts
->u
.derived
->components
->attr
.allocatable
;
675 ts
= &ts
->u
.derived
->components
->ts
;
678 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
679 || attr
->select_type_temporary
|| attr
->associate_var
;
682 /* We cannot build the class container yet. */
685 /* Determine the name of the encapsulating type. */
686 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
691 get_unique_hashed_string (tname
, ts
->u
.derived
);
692 if ((*as
) && attr
->allocatable
)
693 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
694 else if ((*as
) && attr
->pointer
)
695 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
697 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
698 else if (attr
->pointer
)
699 name
= xasprintf ("__class_%s_p", tname
);
700 else if (attr
->allocatable
)
701 name
= xasprintf ("__class_%s_a", tname
);
703 name
= xasprintf ("__class_%s_t", tname
);
705 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
707 /* Find the top-level namespace. */
708 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
713 ns
= ts
->u
.derived
->ns
;
715 /* Although this might seem to be counterintuitive, we can build separate
716 class types with different array specs because the TKR interface checks
717 work on the declared type. All array type other than deferred shape or
718 assumed rank are added to the function namespace to ensure that they
719 are properly distinguished. */
720 if (attr
->dummy
&& (*as
)
721 && ((!attr
->codimension
722 && !((*as
)->type
== AS_DEFERRED
|| (*as
)->type
== AS_ASSUMED_RANK
))
723 || (attr
->codimension
724 && !((*as
)->cotype
== AS_DEFERRED
725 || (*as
)->cotype
== AS_ASSUMED_RANK
))))
729 gfc_find_symbol (name
, ns
, 0, &fclass
);
730 /* If a local class type with this name already exists, update the
731 name with an index. */
735 sname
= xasprintf ("%s_%d", name
, ++ctr
);
741 gfc_find_symbol (name
, ns
, 0, &fclass
);
746 /* If not there, create a new symbol. */
747 fclass
= gfc_new_symbol (name
, ns
);
748 st
= gfc_new_symtree (&ns
->sym_root
, name
);
750 gfc_set_sym_referenced (fclass
);
752 fclass
->ts
.type
= BT_UNKNOWN
;
753 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
754 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
755 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
756 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
760 /* Add component '_data'. */
761 if (!gfc_add_component (fclass
, "_data", &c
))
764 c
->ts
.type
= BT_DERIVED
;
765 c
->attr
.access
= ACCESS_PRIVATE
;
766 c
->ts
.u
.derived
= ts
->u
.derived
;
767 c
->attr
.class_pointer
= attr
->pointer
;
768 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
769 || attr
->select_type_temporary
;
770 c
->attr
.allocatable
= attr
->allocatable
;
771 c
->attr
.dimension
= attr
->dimension
;
772 c
->attr
.codimension
= attr
->codimension
;
773 c
->attr
.abstract
= fclass
->attr
.abstract
;
775 c
->initializer
= NULL
;
777 /* Add component '_vptr'. */
778 if (!gfc_add_component (fclass
, "_vptr", &c
))
780 c
->ts
.type
= BT_DERIVED
;
781 c
->attr
.access
= ACCESS_PRIVATE
;
784 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
786 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
788 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
790 /* Add component '_len'. Only unlimited polymorphic pointers may
791 have a string assigned to them, i.e., only those need the _len
793 if (!gfc_add_component (fclass
, "_len", &c
))
795 c
->ts
.type
= BT_INTEGER
;
796 c
->ts
.kind
= gfc_charlen_int_kind
;
797 c
->attr
.access
= ACCESS_PRIVATE
;
798 c
->attr
.artificial
= 1;
801 /* Build vtab later. */
802 c
->ts
.u
.derived
= NULL
;
805 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
807 /* Since the extension field is 8 bit wide, we can only have
808 up to 255 extension levels. */
809 if (ts
->u
.derived
->attr
.extension
== 255)
811 gfc_error ("Maximum extension level reached with type %qs at %L",
812 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
816 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
817 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
818 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
821 fclass
->attr
.is_class
= 1;
822 orig_ts
->u
.derived
= fclass
;
823 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
830 /* Change class, using gfc_build_class_symbol. This is needed for associate
831 names, when rank changes or a derived type is produced by resolution. */
834 gfc_change_class (gfc_typespec
*ts
, symbol_attribute
*sym_attr
,
835 gfc_array_spec
*sym_as
, int rank
, int corank
)
837 symbol_attribute attr
;
839 gfc_array_spec
*as
= NULL
;
840 gfc_symbol
*der
= ts
->u
.derived
;
845 attr
.associate_var
= 1;
846 attr
.class_pointer
= 1;
847 attr
.allocatable
= 0;
849 attr
.dimension
= rank
? 1 : 0;
853 as
= gfc_copy_array_spec (sym_as
);
856 as
= gfc_get_array_spec ();
858 as
->type
= AS_DEFERRED
;
862 if (as
&& as
->corank
!= 0)
863 attr
.codimension
= 1;
865 if (!gfc_build_class_symbol (ts
, &attr
, &as
))
868 gfc_set_sym_referenced (ts
->u
.derived
);
870 /* Make sure the _vptr is set. */
871 c
= gfc_find_component (ts
->u
.derived
, "_vptr", true, true, NULL
);
872 if (c
->ts
.u
.derived
== NULL
)
873 c
->ts
.u
.derived
= gfc_find_derived_vtab (der
);
874 /* _vptr now has the _vtab in it, change it to the _vtype. */
875 if (c
->ts
.u
.derived
->attr
.vtab
)
876 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
880 /* Add a procedure pointer component to the vtype
881 to represent a specific type-bound procedure. */
884 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
887 bool is_abstract
= false;
889 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
891 /* If the present component typebound proc is abstract, the new version
892 should unconditionally be tested if it is a suitable replacement. */
893 if (c
&& c
->tb
&& c
->tb
->u
.specific
894 && c
->tb
->u
.specific
->n
.sym
->attr
.abstract
)
897 /* Pass on the new tb being not overridable if a component is found and
898 either there is not an overridden specific or the present component
899 tb is abstract. This ensures that possible, viable replacements are
901 if (tb
->non_overridable
&& !tb
->overridden
&& !is_abstract
&& c
)
906 /* Add procedure component. */
907 if (!gfc_add_component (vtype
, name
, &c
))
911 c
->tb
= XCNEW (gfc_typebound_proc
);
914 c
->attr
.procedure
= 1;
915 c
->attr
.proc_pointer
= 1;
916 c
->attr
.flavor
= FL_PROCEDURE
;
917 c
->attr
.access
= ACCESS_PRIVATE
;
918 c
->attr
.external
= 1;
920 c
->attr
.if_source
= IFSRC_IFBODY
;
922 else if (c
->attr
.proc_pointer
&& c
->tb
)
930 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
931 c
->ts
.interface
= ifc
;
933 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
934 c
->attr
.pure
= ifc
->attr
.pure
;
939 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
942 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
948 add_procs_to_declared_vtab1 (st
->left
, vtype
);
951 add_procs_to_declared_vtab1 (st
->right
, vtype
);
953 if (st
->n
.tb
&& !st
->n
.tb
->error
954 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
955 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
959 /* Copy procedure pointers components from the parent type. */
962 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
967 vtab
= gfc_find_derived_vtab (declared
);
969 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
971 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
974 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
979 /* Returns true if any of its nonpointer nonallocatable components or
980 their nonpointer nonallocatable subcomponents has a finalization
984 has_finalizer_component (gfc_symbol
*derived
)
988 for (c
= derived
->components
; c
; c
= c
->next
)
989 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
990 && c
->attr
.flavor
!= FL_PROCEDURE
)
992 if (c
->ts
.u
.derived
->f2k_derived
993 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
996 /* Stop infinite recursion through this function by inhibiting
997 calls when the derived type and that of the component are
999 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
1000 && has_finalizer_component (c
->ts
.u
.derived
))
1008 comp_is_finalizable (gfc_component
*comp
)
1010 if (comp
->attr
.proc_pointer
)
1012 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
1014 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
1015 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1016 || has_finalizer_component (comp
->ts
.u
.derived
)
1017 || (comp
->ts
.u
.derived
->f2k_derived
1018 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
1020 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1021 && CLASS_DATA (comp
)->attr
.allocatable
)
1028 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
1029 neither allocatable nor a pointer but has a finalizer, call it. If it
1030 is a nonpointer component with allocatable components or has finalizers, walk
1031 them. Either of them is required; other nonallocatables and pointers aren't
1033 Note: If the component is allocatable, the DEALLOCATE handling takes care
1034 of calling the appropriate finalizers, coarray deregistering, and
1035 deallocation of allocatable subcomponents. */
1038 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
1039 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
1040 gfc_namespace
*sub_ns
)
1044 gfc_was_finalized
*f
;
1046 if (!comp_is_finalizable (comp
))
1049 /* If this expression with this component has been finalized
1050 already in this namespace, there is nothing to do. */
1051 for (f
= sub_ns
->was_finalized
; f
; f
= f
->next
)
1053 if (f
->e
== expr
&& f
->c
== comp
)
1057 e
= gfc_copy_expr (expr
);
1059 e
->ref
= ref
= gfc_get_ref ();
1062 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
1064 ref
->next
= gfc_get_ref ();
1067 ref
->type
= REF_COMPONENT
;
1068 ref
->u
.c
.sym
= derived
;
1069 ref
->u
.c
.component
= comp
;
1072 if (comp
->attr
.dimension
|| comp
->attr
.codimension
1073 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1074 && (CLASS_DATA (comp
)->attr
.dimension
1075 || CLASS_DATA (comp
)->attr
.codimension
)))
1077 ref
->next
= gfc_get_ref ();
1078 ref
->next
->type
= REF_ARRAY
;
1079 ref
->next
->u
.ar
.dimen
= 0;
1080 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
1082 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
1083 e
->corank
= ref
->next
->u
.ar
.as
->corank
;
1084 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
1087 /* Call DEALLOCATE (comp, stat=ignore). */
1088 if (comp
->attr
.allocatable
1089 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1090 && CLASS_DATA (comp
)->attr
.allocatable
))
1092 gfc_code
*dealloc
, *block
= NULL
;
1094 /* Add IF (fini_coarray). */
1095 if (comp
->attr
.codimension
1096 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1097 && CLASS_DATA (comp
)->attr
.codimension
))
1099 block
= gfc_get_code (EXEC_IF
);
1102 (*code
)->next
= block
;
1103 (*code
) = (*code
)->next
;
1108 block
->block
= gfc_get_code (EXEC_IF
);
1109 block
= block
->block
;
1110 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
1113 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
1115 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
1116 dealloc
->ext
.alloc
.list
->expr
= e
;
1117 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
1119 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
1120 cond
->block
= gfc_get_code (EXEC_IF
);
1121 cond
->block
->expr1
= gfc_get_expr ();
1122 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
1123 cond
->block
->expr1
->where
= gfc_current_locus
;
1124 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
1125 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1126 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1127 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
1128 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
1129 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
1130 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1131 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
1132 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
1133 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
1134 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1135 cond
->block
->next
= dealloc
;
1141 (*code
)->next
= cond
;
1142 (*code
) = (*code
)->next
;
1148 else if (comp
->ts
.type
== BT_DERIVED
1149 && comp
->ts
.u
.derived
->f2k_derived
1150 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1152 /* Call FINAL_WRAPPER (comp); */
1153 gfc_code
*final_wrap
;
1154 gfc_symbol
*vtab
, *byte_stride
;
1155 gfc_expr
*scalar
, *size_expr
, *fini_coarray_expr
;
1158 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1159 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1160 if (strcmp (c
->name
, "_final") == 0)
1165 /* Set scalar argument for storage_size. A leading underscore in
1166 the name prevents an unwanted finalization. */
1167 gfc_get_symbol ("_comp_byte_stride", sub_ns
, &byte_stride
);
1168 byte_stride
->ts
= e
->ts
;
1169 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1170 byte_stride
->attr
.value
= 1;
1171 byte_stride
->attr
.artificial
= 1;
1172 gfc_set_sym_referenced (byte_stride
);
1173 gfc_commit_symbol (byte_stride
);
1174 scalar
= gfc_lval_expr_from_sym (byte_stride
);
1176 final_wrap
= gfc_get_code (EXEC_CALL
);
1177 final_wrap
->symtree
= c
->initializer
->symtree
;
1178 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1179 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1180 final_wrap
->ext
.actual
->expr
= e
;
1182 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1183 size_expr
= gfc_get_expr ();
1184 size_expr
->where
= gfc_current_locus
;
1185 size_expr
->expr_type
= EXPR_OP
;
1186 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1188 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1189 size_expr
->value
.op
.op1
1190 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1191 "storage_size", gfc_current_locus
, 2,
1193 gfc_get_int_expr (gfc_index_integer_kind
,
1196 /* NUMERIC_STORAGE_SIZE. */
1197 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1198 gfc_character_storage_size
);
1199 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1200 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1202 /* Which provides the argument 'byte_stride'..... */
1203 final_wrap
->ext
.actual
->next
= gfc_get_actual_arglist ();
1204 final_wrap
->ext
.actual
->next
->expr
= size_expr
;
1206 /* ...and last of all the 'fini_coarray' argument. */
1207 fini_coarray_expr
= gfc_lval_expr_from_sym (fini_coarray
);
1208 final_wrap
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1209 final_wrap
->ext
.actual
->next
->next
->expr
= fini_coarray_expr
;
1215 (*code
)->next
= final_wrap
;
1216 (*code
) = (*code
)->next
;
1219 (*code
) = final_wrap
;
1225 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1226 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1231 /* Record that this was finalized already in this namespace. */
1232 f
= sub_ns
->was_finalized
;
1233 sub_ns
->was_finalized
= XCNEW (gfc_was_finalized
);
1234 sub_ns
->was_finalized
->e
= expr
;
1235 sub_ns
->was_finalized
->c
= comp
;
1236 sub_ns
->was_finalized
->next
= f
;
1240 /* Generate code equivalent to
1241 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1242 + offset, c_ptr), ptr). */
1245 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1246 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1249 gfc_expr
*expr
, *expr2
;
1251 /* C_F_POINTER(). */
1252 block
= gfc_get_code (EXEC_CALL
);
1253 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1254 block
->resolved_sym
= block
->symtree
->n
.sym
;
1255 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1256 block
->resolved_sym
->attr
.intrinsic
= 1;
1257 block
->resolved_sym
->attr
.subroutine
= 1;
1258 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1259 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1260 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1261 gfc_commit_symbol (block
->resolved_sym
);
1263 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1264 block
->ext
.actual
= gfc_get_actual_arglist ();
1265 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1266 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1268 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1270 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1272 /* TRANSFER's first argument: C_LOC (array). */
1273 expr
= gfc_get_expr ();
1274 expr
->expr_type
= EXPR_FUNCTION
;
1275 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1276 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1277 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1278 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1279 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1280 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1281 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1282 expr
->value
.function
.actual
->expr
1283 = gfc_lval_expr_from_sym (array
);
1284 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1285 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1286 expr
->ts
.type
= BT_INTEGER
;
1287 expr
->ts
.kind
= gfc_index_integer_kind
;
1288 expr
->where
= gfc_current_locus
;
1291 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1292 gfc_current_locus
, 3, expr
,
1293 gfc_get_int_expr (gfc_index_integer_kind
,
1295 expr2
->ts
.type
= BT_INTEGER
;
1296 expr2
->ts
.kind
= gfc_index_integer_kind
;
1298 /* <array addr> + <offset>. */
1299 block
->ext
.actual
->expr
= gfc_get_expr ();
1300 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1301 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1302 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1303 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1304 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1305 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1307 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1308 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1309 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1310 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1316 /* Calculates the offset to the (idx+1)th element of an array, taking the
1317 stride into account. It generates the code:
1320 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1322 offset = offset * byte_stride. */
1325 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1326 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1327 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1328 gfc_code
*block
, gfc_namespace
*sub_ns
)
1331 gfc_expr
*expr
, *expr2
;
1334 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1335 block
= block
->next
;
1336 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1337 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1340 iter
= gfc_get_iterator ();
1341 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1342 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1343 iter
->end
= gfc_copy_expr (rank
);
1344 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1345 block
->next
= gfc_get_code (EXEC_DO
);
1346 block
= block
->next
;
1347 block
->ext
.iterator
= iter
;
1348 block
->block
= gfc_get_code (EXEC_DO
);
1350 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1353 /* mod (idx, sizes(idx2)). */
1354 expr
= gfc_lval_expr_from_sym (sizes
);
1355 expr
->ref
= gfc_get_ref ();
1356 expr
->ref
->type
= REF_ARRAY
;
1357 expr
->ref
->u
.ar
.as
= sizes
->as
;
1358 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1359 expr
->ref
->u
.ar
.dimen
= 1;
1360 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1361 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1362 expr
->where
= sizes
->declared_at
;
1364 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1365 gfc_current_locus
, 2,
1366 gfc_lval_expr_from_sym (idx
), expr
);
1369 /* (...) / sizes(idx2-1). */
1370 expr2
= gfc_get_expr ();
1371 expr2
->expr_type
= EXPR_OP
;
1372 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1373 expr2
->value
.op
.op1
= expr
;
1374 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1375 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1376 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1377 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1378 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1379 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1380 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1381 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1382 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1383 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1384 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1385 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1386 = gfc_lval_expr_from_sym (idx2
);
1387 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1388 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1389 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1390 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1391 expr2
->ts
= idx
->ts
;
1392 expr2
->where
= gfc_current_locus
;
1394 /* ... * strides(idx2). */
1395 expr
= gfc_get_expr ();
1396 expr
->expr_type
= EXPR_OP
;
1397 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1398 expr
->value
.op
.op1
= expr2
;
1399 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1400 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1401 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1402 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1403 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1404 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1405 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1406 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1408 expr
->where
= gfc_current_locus
;
1410 /* offset = offset + ... */
1411 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1412 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1413 block
->block
->next
->expr2
= gfc_get_expr ();
1414 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1415 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1416 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1417 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1418 block
->block
->next
->expr2
->ts
= idx
->ts
;
1419 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1421 /* After the loop: offset = offset * byte_stride. */
1422 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1423 block
= block
->next
;
1424 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1425 block
->expr2
= gfc_get_expr ();
1426 block
->expr2
->expr_type
= EXPR_OP
;
1427 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1428 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1429 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1430 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1431 block
->expr2
->where
= gfc_current_locus
;
1436 /* Insert code of the following form:
1439 integer(c_intptr_t) :: i
1441 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1442 && (is_contiguous || !final_rank3->attr.contiguous
1443 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1444 || 0 == STORAGE_SIZE (array)) then
1445 call final_rank3 (array)
1448 integer(c_intptr_t) :: offset, j
1449 type(t) :: tmp(shape (array))
1451 do i = 0, size (array)-1
1452 offset = obtain_offset(i, strides, sizes, byte_stride)
1453 addr = transfer (c_loc (array), addr) + offset
1454 call c_f_pointer (transfer (addr, cptr), ptr)
1456 addr = transfer (c_loc (tmp), addr)
1457 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1458 call c_f_pointer (transfer (addr, cptr), ptr2)
1461 call final_rank3 (tmp)
1467 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1468 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1469 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1471 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1472 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1473 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1474 gfc_namespace
*sub_ns
)
1476 gfc_symbol
*tmp_array
, *ptr2
;
1477 gfc_expr
*size_expr
, *offset2
, *expr
;
1483 block
->next
= gfc_get_code (EXEC_IF
);
1484 block
= block
->next
;
1486 block
->block
= gfc_get_code (EXEC_IF
);
1487 block
= block
->block
;
1489 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1490 size_expr
= gfc_get_expr ();
1491 size_expr
->where
= gfc_current_locus
;
1492 size_expr
->expr_type
= EXPR_OP
;
1493 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1495 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1496 size_expr
->value
.op
.op1
1497 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1498 "storage_size", gfc_current_locus
, 2,
1499 gfc_lval_expr_from_sym (array
),
1500 gfc_get_int_expr (gfc_index_integer_kind
,
1503 /* NUMERIC_STORAGE_SIZE. */
1504 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1505 gfc_character_storage_size
);
1506 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1507 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1509 /* IF condition: (stride == size_expr
1510 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1512 || 0 == size_expr. */
1513 block
->expr1
= gfc_get_expr ();
1514 block
->expr1
->ts
.type
= BT_LOGICAL
;
1515 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1516 block
->expr1
->expr_type
= EXPR_OP
;
1517 block
->expr1
->where
= gfc_current_locus
;
1519 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1521 /* byte_stride == size_expr */
1522 expr
= gfc_get_expr ();
1523 expr
->ts
.type
= BT_LOGICAL
;
1524 expr
->ts
.kind
= gfc_default_logical_kind
;
1525 expr
->expr_type
= EXPR_OP
;
1526 expr
->where
= gfc_current_locus
;
1527 expr
->value
.op
.op
= INTRINSIC_EQ
;
1529 = gfc_lval_expr_from_sym (byte_stride
);
1530 expr
->value
.op
.op2
= size_expr
;
1532 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1533 add is_contiguous check. */
1535 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1536 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1539 expr2
= gfc_get_expr ();
1540 expr2
->ts
.type
= BT_LOGICAL
;
1541 expr2
->ts
.kind
= gfc_default_logical_kind
;
1542 expr2
->expr_type
= EXPR_OP
;
1543 expr2
->where
= gfc_current_locus
;
1544 expr2
->value
.op
.op
= INTRINSIC_AND
;
1545 expr2
->value
.op
.op1
= expr
;
1546 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1550 block
->expr1
->value
.op
.op1
= expr
;
1552 /* 0 == size_expr */
1553 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1554 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1555 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1556 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1557 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1558 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1559 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1560 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1561 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1563 /* IF body: call final subroutine. */
1564 block
->next
= gfc_get_code (EXEC_CALL
);
1565 block
->next
->symtree
= fini
->proc_tree
;
1566 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1567 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1568 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1572 block
->block
= gfc_get_code (EXEC_IF
);
1573 block
= block
->block
;
1575 /* BLOCK ... END BLOCK. */
1576 block
->next
= gfc_get_code (EXEC_BLOCK
);
1577 block
= block
->next
;
1579 ns
= gfc_build_block_ns (sub_ns
);
1580 block
->ext
.block
.ns
= ns
;
1581 block
->ext
.block
.assoc
= NULL
;
1583 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1584 ptr2
->ts
.type
= BT_DERIVED
;
1585 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1586 ptr2
->attr
.flavor
= FL_VARIABLE
;
1587 ptr2
->attr
.pointer
= 1;
1588 ptr2
->attr
.artificial
= 1;
1589 gfc_set_sym_referenced (ptr2
);
1590 gfc_commit_symbol (ptr2
);
1592 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1593 tmp_array
->ts
.type
= BT_DERIVED
;
1594 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1595 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1596 tmp_array
->attr
.dimension
= 1;
1597 tmp_array
->attr
.artificial
= 1;
1598 tmp_array
->as
= gfc_get_array_spec();
1599 tmp_array
->attr
.intent
= INTENT_INOUT
;
1600 tmp_array
->as
->type
= AS_EXPLICIT
;
1601 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1603 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1605 gfc_expr
*shape_expr
;
1606 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1608 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1610 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1611 gfc_current_locus
, 3,
1612 gfc_lval_expr_from_sym (array
),
1613 gfc_get_int_expr (gfc_default_integer_kind
,
1615 gfc_get_int_expr (gfc_default_integer_kind
,
1617 gfc_index_integer_kind
));
1618 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1619 tmp_array
->as
->upper
[i
] = shape_expr
;
1621 gfc_set_sym_referenced (tmp_array
);
1622 gfc_commit_symbol (tmp_array
);
1625 iter
= gfc_get_iterator ();
1626 iter
->var
= gfc_lval_expr_from_sym (idx
);
1627 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1628 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1629 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1631 block
= gfc_get_code (EXEC_DO
);
1633 block
->ext
.iterator
= iter
;
1634 block
->block
= gfc_get_code (EXEC_DO
);
1636 /* Offset calculation for the new array: idx * size of type (in bytes). */
1637 offset2
= gfc_get_expr ();
1638 offset2
->expr_type
= EXPR_OP
;
1639 offset2
->where
= gfc_current_locus
;
1640 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1641 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1642 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1643 offset2
->ts
= byte_stride
->ts
;
1645 /* Offset calculation of "array". */
1646 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1647 byte_stride
, rank
, block
->block
, sub_ns
);
1650 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1651 + idx * stride, c_ptr), ptr). */
1652 block2
->next
= finalization_scalarizer (array
, ptr
,
1653 gfc_lval_expr_from_sym (offset
),
1655 block2
= block2
->next
;
1656 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1657 block2
= block2
->next
;
1660 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1661 block2
= block2
->next
;
1662 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1663 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1665 /* Call now the user's final subroutine. */
1666 block
->next
= gfc_get_code (EXEC_CALL
);
1667 block
= block
->next
;
1668 block
->symtree
= fini
->proc_tree
;
1669 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1670 block
->ext
.actual
= gfc_get_actual_arglist ();
1671 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1673 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1679 iter
= gfc_get_iterator ();
1680 iter
->var
= gfc_lval_expr_from_sym (idx
);
1681 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1682 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1683 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1685 block
->next
= gfc_get_code (EXEC_DO
);
1686 block
= block
->next
;
1687 block
->ext
.iterator
= iter
;
1688 block
->block
= gfc_get_code (EXEC_DO
);
1690 /* Offset calculation of "array". */
1691 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1692 byte_stride
, rank
, block
->block
, sub_ns
);
1695 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1696 + offset, c_ptr), ptr). */
1697 block2
->next
= finalization_scalarizer (array
, ptr
,
1698 gfc_lval_expr_from_sym (offset
),
1700 block2
= block2
->next
;
1701 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1702 gfc_copy_expr (offset2
), sub_ns
);
1703 block2
= block2
->next
;
1706 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1707 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1708 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1712 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1713 derived type "derived". The function first calls the appropriate FINAL
1714 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1715 components (but not the inherited ones). Last, it calls the wrapper
1716 subroutine of the parent. The generated wrapper procedure takes as argument
1717 an assumed-rank array.
1718 If neither allocatable components nor FINAL subroutines exists, the vtab
1719 will contain a NULL pointer.
1720 The generated function has the form
1721 _final(assumed-rank array, stride, skip_corarray)
1722 where the array has to be contiguous (except of the lowest dimension). The
1723 stride (in bytes) is used to allow different sizes for ancestor types by
1724 skipping over the additionally added components in the scalarizer. If
1725 "fini_coarray" is false, coarray components are not finalized to allow for
1726 the correct semantic with intrinsic assignment. */
1729 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1730 const char *tname
, gfc_component
*vtab_final
)
1732 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1733 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1734 gfc_component
*comp
;
1735 gfc_namespace
*sub_ns
;
1736 gfc_code
*last_code
, *block
;
1738 bool finalizable_comp
= false;
1739 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1742 if (derived
->attr
.unlimited_polymorphic
|| derived
->error
)
1744 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1748 /* Search for the ancestor's finalizers. */
1749 if (derived
->attr
.extension
&& derived
->components
1750 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1751 || has_finalizer_component (derived
)))
1754 gfc_component
*comp
;
1756 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1757 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1758 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1760 ancestor_wrapper
= comp
->initializer
;
1765 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1766 components: Return a NULL() expression; we defer this a bit to have
1767 an interface declaration. */
1768 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1769 && !derived
->attr
.alloc_comp
1770 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1771 && !has_finalizer_component (derived
))
1773 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1774 gcc_assert (vtab_final
->ts
.interface
== NULL
);
1778 /* Check whether there are new allocatable components. */
1779 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1781 if (comp
== derived
->components
&& derived
->attr
.extension
1782 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1785 finalizable_comp
|= comp_is_finalizable (comp
);
1788 /* If there is no new finalizer and no new allocatable, return with
1789 an expr to the ancestor's one. */
1790 if (!finalizable_comp
1791 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1793 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1794 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1795 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1796 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1800 /* We now create a wrapper, which does the following:
1801 1. Call the suitable finalization subroutine for this type
1802 2. Loop over all noninherited allocatable components and noninherited
1803 components with allocatable components and DEALLOCATE those; this will
1804 take care of finalizers, coarray deregistering and allocatable
1806 3. Call the ancestor's finalizer. */
1808 /* Declare the wrapper function; it takes an assumed-rank array
1809 and a VALUE logical as arguments. */
1811 /* Set up the namespace. */
1812 sub_ns
= gfc_get_namespace (ns
, 0);
1813 sub_ns
->sibling
= ns
->contained
;
1814 ns
->contained
= sub_ns
;
1815 sub_ns
->resolved
= 1;
1817 /* Set up the procedure symbol. */
1818 name
= xasprintf ("__final_%s", tname
);
1819 gfc_get_symbol (name
, sub_ns
, &final
);
1820 sub_ns
->proc_name
= final
;
1821 final
->attr
.flavor
= FL_PROCEDURE
;
1822 final
->attr
.function
= 1;
1823 final
->attr
.pure
= 0;
1824 final
->attr
.recursive
= 1;
1825 final
->result
= final
;
1826 final
->ts
.type
= BT_INTEGER
;
1828 final
->attr
.artificial
= 1;
1829 final
->attr
.always_explicit
= 1;
1830 final
->attr
.if_source
= IFSRC_DECL
;
1831 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1832 final
->module
= ns
->proc_name
->name
;
1833 gfc_set_sym_referenced (final
);
1834 gfc_commit_symbol (final
);
1836 /* Set up formal argument. */
1837 gfc_get_symbol ("array", sub_ns
, &array
);
1838 array
->ts
.type
= BT_DERIVED
;
1839 array
->ts
.u
.derived
= derived
;
1840 array
->attr
.flavor
= FL_VARIABLE
;
1841 array
->attr
.dummy
= 1;
1842 array
->attr
.contiguous
= 1;
1843 array
->attr
.dimension
= 1;
1844 array
->attr
.artificial
= 1;
1845 array
->as
= gfc_get_array_spec();
1846 array
->as
->type
= AS_ASSUMED_RANK
;
1847 array
->as
->rank
= -1;
1848 array
->attr
.intent
= INTENT_INOUT
;
1849 gfc_set_sym_referenced (array
);
1850 final
->formal
= gfc_get_formal_arglist ();
1851 final
->formal
->sym
= array
;
1852 gfc_commit_symbol (array
);
1854 /* Set up formal argument. */
1855 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1856 byte_stride
->ts
.type
= BT_INTEGER
;
1857 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1858 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1859 byte_stride
->attr
.dummy
= 1;
1860 byte_stride
->attr
.value
= 1;
1861 byte_stride
->attr
.artificial
= 1;
1862 gfc_set_sym_referenced (byte_stride
);
1863 final
->formal
->next
= gfc_get_formal_arglist ();
1864 final
->formal
->next
->sym
= byte_stride
;
1865 gfc_commit_symbol (byte_stride
);
1867 /* Set up formal argument. */
1868 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1869 fini_coarray
->ts
.type
= BT_LOGICAL
;
1870 fini_coarray
->ts
.kind
= 1;
1871 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1872 fini_coarray
->attr
.dummy
= 1;
1873 fini_coarray
->attr
.value
= 1;
1874 fini_coarray
->attr
.artificial
= 1;
1875 gfc_set_sym_referenced (fini_coarray
);
1876 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1877 final
->formal
->next
->next
->sym
= fini_coarray
;
1878 gfc_commit_symbol (fini_coarray
);
1880 /* Local variables. */
1882 gfc_get_symbol ("idx", sub_ns
, &idx
);
1883 idx
->ts
.type
= BT_INTEGER
;
1884 idx
->ts
.kind
= gfc_index_integer_kind
;
1885 idx
->attr
.flavor
= FL_VARIABLE
;
1886 idx
->attr
.artificial
= 1;
1887 gfc_set_sym_referenced (idx
);
1888 gfc_commit_symbol (idx
);
1890 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1891 idx2
->ts
.type
= BT_INTEGER
;
1892 idx2
->ts
.kind
= gfc_index_integer_kind
;
1893 idx2
->attr
.flavor
= FL_VARIABLE
;
1894 idx2
->attr
.artificial
= 1;
1895 gfc_set_sym_referenced (idx2
);
1896 gfc_commit_symbol (idx2
);
1898 gfc_get_symbol ("offset", sub_ns
, &offset
);
1899 offset
->ts
.type
= BT_INTEGER
;
1900 offset
->ts
.kind
= gfc_index_integer_kind
;
1901 offset
->attr
.flavor
= FL_VARIABLE
;
1902 offset
->attr
.artificial
= 1;
1903 gfc_set_sym_referenced (offset
);
1904 gfc_commit_symbol (offset
);
1906 /* Create RANK expression. */
1907 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1908 gfc_current_locus
, 1,
1909 gfc_lval_expr_from_sym (array
));
1910 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1911 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1913 /* Create is_contiguous variable. */
1914 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1915 is_contiguous
->ts
.type
= BT_LOGICAL
;
1916 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1917 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1918 is_contiguous
->attr
.artificial
= 1;
1919 gfc_set_sym_referenced (is_contiguous
);
1920 gfc_commit_symbol (is_contiguous
);
1922 /* Create "sizes(0..rank)" variable, which contains the multiplied
1923 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1924 sizes(2) = sizes(1) * extent(dim=2) etc. */
1925 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1926 sizes
->ts
.type
= BT_INTEGER
;
1927 sizes
->ts
.kind
= gfc_index_integer_kind
;
1928 sizes
->attr
.flavor
= FL_VARIABLE
;
1929 sizes
->attr
.dimension
= 1;
1930 sizes
->attr
.artificial
= 1;
1931 sizes
->as
= gfc_get_array_spec();
1932 sizes
->attr
.intent
= INTENT_INOUT
;
1933 sizes
->as
->type
= AS_EXPLICIT
;
1934 sizes
->as
->rank
= 1;
1935 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1936 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1937 gfc_set_sym_referenced (sizes
);
1938 gfc_commit_symbol (sizes
);
1940 /* Create "strides(1..rank)" variable, which contains the strides per
1942 gfc_get_symbol ("strides", sub_ns
, &strides
);
1943 strides
->ts
.type
= BT_INTEGER
;
1944 strides
->ts
.kind
= gfc_index_integer_kind
;
1945 strides
->attr
.flavor
= FL_VARIABLE
;
1946 strides
->attr
.dimension
= 1;
1947 strides
->attr
.artificial
= 1;
1948 strides
->as
= gfc_get_array_spec();
1949 strides
->attr
.intent
= INTENT_INOUT
;
1950 strides
->as
->type
= AS_EXPLICIT
;
1951 strides
->as
->rank
= 1;
1952 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1953 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1954 gfc_set_sym_referenced (strides
);
1955 gfc_commit_symbol (strides
);
1958 /* Set return value to 0. */
1959 last_code
= gfc_get_code (EXEC_ASSIGN
);
1960 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1961 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1962 sub_ns
->code
= last_code
;
1964 /* Set: is_contiguous = .true. */
1965 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1966 last_code
= last_code
->next
;
1967 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1968 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1969 &gfc_current_locus
, true);
1971 /* Set: sizes(0) = 1. */
1972 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1973 last_code
= last_code
->next
;
1974 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1975 last_code
->expr1
->ref
= gfc_get_ref ();
1976 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1977 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1978 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1979 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1980 last_code
->expr1
->ref
->u
.ar
.start
[0]
1981 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1982 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1983 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1987 strides(idx) = _F._stride (array, dim=idx)
1988 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1989 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1993 iter
= gfc_get_iterator ();
1994 iter
->var
= gfc_lval_expr_from_sym (idx
);
1995 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1996 iter
->end
= gfc_copy_expr (rank
);
1997 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1998 last_code
->next
= gfc_get_code (EXEC_DO
);
1999 last_code
= last_code
->next
;
2000 last_code
->ext
.iterator
= iter
;
2001 last_code
->block
= gfc_get_code (EXEC_DO
);
2003 /* strides(idx) = _F._stride(array,dim=idx). */
2004 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
2005 block
= last_code
->block
->next
;
2007 block
->expr1
= gfc_lval_expr_from_sym (strides
);
2008 block
->expr1
->ref
= gfc_get_ref ();
2009 block
->expr1
->ref
->type
= REF_ARRAY
;
2010 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2011 block
->expr1
->ref
->u
.ar
.dimen
= 1;
2012 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2013 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
2014 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
2016 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
2017 gfc_current_locus
, 2,
2018 gfc_lval_expr_from_sym (array
),
2019 gfc_lval_expr_from_sym (idx
));
2021 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
2022 block
->next
= gfc_get_code (EXEC_ASSIGN
);
2023 block
= block
->next
;
2025 /* sizes(idx) = ... */
2026 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
2027 block
->expr1
->ref
= gfc_get_ref ();
2028 block
->expr1
->ref
->type
= REF_ARRAY
;
2029 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2030 block
->expr1
->ref
->u
.ar
.dimen
= 1;
2031 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2032 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
2033 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
2035 block
->expr2
= gfc_get_expr ();
2036 block
->expr2
->expr_type
= EXPR_OP
;
2037 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
2038 block
->expr2
->where
= gfc_current_locus
;
2041 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
2042 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2043 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2044 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2045 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2046 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2047 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2048 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
2049 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
2050 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
2051 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
2052 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
2053 = gfc_lval_expr_from_sym (idx
);
2054 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
2055 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2056 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
2057 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
2059 /* size(array, dim=idx, kind=index_kind). */
2060 block
->expr2
->value
.op
.op2
2061 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
2062 gfc_current_locus
, 3,
2063 gfc_lval_expr_from_sym (array
),
2064 gfc_lval_expr_from_sym (idx
),
2065 gfc_get_int_expr (gfc_index_integer_kind
,
2067 gfc_index_integer_kind
));
2068 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
2069 block
->expr2
->ts
= idx
->ts
;
2071 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
2072 block
->next
= gfc_get_code (EXEC_IF
);
2073 block
= block
->next
;
2075 block
->block
= gfc_get_code (EXEC_IF
);
2076 block
= block
->block
;
2078 /* if condition: strides(idx) /= sizes(idx-1). */
2079 block
->expr1
= gfc_get_expr ();
2080 block
->expr1
->ts
.type
= BT_LOGICAL
;
2081 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
2082 block
->expr1
->expr_type
= EXPR_OP
;
2083 block
->expr1
->where
= gfc_current_locus
;
2084 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
2086 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
2087 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
2088 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2089 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2090 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2091 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2092 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
2093 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
2095 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
2096 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
2097 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
2098 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
2099 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
2100 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
2101 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2102 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
2103 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
2104 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
2105 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
2106 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
2107 = gfc_lval_expr_from_sym (idx
);
2108 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
2109 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2110 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
2111 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
2113 /* if body: is_contiguous = .false. */
2114 block
->next
= gfc_get_code (EXEC_ASSIGN
);
2115 block
= block
->next
;
2116 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
2117 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
2118 &gfc_current_locus
, false);
2120 /* Obtain the size (number of elements) of "array" MINUS ONE,
2121 which is used in the scalarization. */
2122 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
2123 nelem
->ts
.type
= BT_INTEGER
;
2124 nelem
->ts
.kind
= gfc_index_integer_kind
;
2125 nelem
->attr
.flavor
= FL_VARIABLE
;
2126 nelem
->attr
.artificial
= 1;
2127 gfc_set_sym_referenced (nelem
);
2128 gfc_commit_symbol (nelem
);
2130 /* nelem = sizes (rank) - 1. */
2131 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
2132 last_code
= last_code
->next
;
2134 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
2136 last_code
->expr2
= gfc_get_expr ();
2137 last_code
->expr2
->expr_type
= EXPR_OP
;
2138 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
2139 last_code
->expr2
->value
.op
.op2
2140 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2141 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
2142 last_code
->expr2
->where
= gfc_current_locus
;
2144 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
2145 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2146 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2147 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2148 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2149 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2150 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
2151 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2153 /* Call final subroutines. We now generate code like:
2155 integer, pointer :: ptr
2157 integer(c_intptr_t) :: i, addr
2159 select case (rank (array))
2161 ! If needed, the array is packed
2162 call final_rank3 (array)
2164 do i = 0, size (array)-1
2165 addr = transfer (c_loc (array), addr) + i * stride
2166 call c_f_pointer (transfer (addr, cptr), ptr)
2167 call elemental_final (ptr)
2171 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2173 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2175 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
2176 ptr
->ts
.type
= BT_DERIVED
;
2177 ptr
->ts
.u
.derived
= derived
;
2178 ptr
->attr
.flavor
= FL_VARIABLE
;
2179 ptr
->attr
.pointer
= 1;
2180 ptr
->attr
.artificial
= 1;
2181 gfc_set_sym_referenced (ptr
);
2182 gfc_commit_symbol (ptr
);
2184 fini
= derived
->f2k_derived
->finalizers
;
2186 /* Assumed rank finalizers can be called directly. The call takes care
2187 of setting up the descriptor. resolve_finalizers has already checked
2188 that this is the only finalizer for this kind/type (F2018: C790). */
2189 if (fini
->proc_tree
&& fini
->proc_tree
->n
.sym
->formal
->sym
->as
2190 && fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
== AS_ASSUMED_RANK
)
2192 last_code
->next
= gfc_get_code (EXEC_CALL
);
2193 last_code
->next
->symtree
= fini
->proc_tree
;
2194 last_code
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2195 last_code
->next
->ext
.actual
= gfc_get_actual_arglist ();
2196 last_code
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2198 last_code
= last_code
->next
;
2199 goto finish_assumed_rank
;
2202 /* SELECT CASE (RANK (array)). */
2203 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2204 last_code
= last_code
->next
;
2205 last_code
->expr1
= gfc_copy_expr (rank
);
2209 for (; fini
; fini
= fini
->next
)
2211 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2212 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2218 /* CASE (fini_rank). */
2221 block
->block
= gfc_get_code (EXEC_SELECT
);
2222 block
= block
->block
;
2226 block
= gfc_get_code (EXEC_SELECT
);
2227 last_code
->block
= block
;
2229 block
->ext
.block
.case_list
= gfc_get_case ();
2230 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2231 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2232 block
->ext
.block
.case_list
->low
2233 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2234 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2236 block
->ext
.block
.case_list
->low
2237 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2238 block
->ext
.block
.case_list
->high
2239 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2241 /* CALL fini_rank (array) - possibly with packing. */
2242 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2243 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2244 idx
, ptr
, nelem
, strides
,
2245 sizes
, idx2
, offset
, is_contiguous
,
2249 block
->next
= gfc_get_code (EXEC_CALL
);
2250 block
->next
->symtree
= fini
->proc_tree
;
2251 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2252 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2253 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2257 /* Elemental call - scalarized. */
2263 block
->block
= gfc_get_code (EXEC_SELECT
);
2264 block
= block
->block
;
2268 block
= gfc_get_code (EXEC_SELECT
);
2269 last_code
->block
= block
;
2271 block
->ext
.block
.case_list
= gfc_get_case ();
2274 iter
= gfc_get_iterator ();
2275 iter
->var
= gfc_lval_expr_from_sym (idx
);
2276 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2277 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2278 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2279 block
->next
= gfc_get_code (EXEC_DO
);
2280 block
= block
->next
;
2281 block
->ext
.iterator
= iter
;
2282 block
->block
= gfc_get_code (EXEC_DO
);
2284 /* Offset calculation. */
2285 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2286 byte_stride
, rank
, block
->block
,
2290 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2291 + offset, c_ptr), ptr). */
2293 = finalization_scalarizer (array
, ptr
,
2294 gfc_lval_expr_from_sym (offset
),
2296 block
= block
->next
;
2298 /* CALL final_elemental (array). */
2299 block
->next
= gfc_get_code (EXEC_CALL
);
2300 block
= block
->next
;
2301 block
->symtree
= fini_elem
->proc_tree
;
2302 block
->resolved_sym
= fini_elem
->proc_sym
;
2303 block
->ext
.actual
= gfc_get_actual_arglist ();
2304 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2308 finish_assumed_rank
:
2310 /* Finalize and deallocate allocatable components. The same manual
2311 scalarization is used as above. */
2313 if (finalizable_comp
)
2316 gfc_code
*block
= NULL
;
2320 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2321 ptr
->ts
.type
= BT_DERIVED
;
2322 ptr
->ts
.u
.derived
= derived
;
2323 ptr
->attr
.flavor
= FL_VARIABLE
;
2324 ptr
->attr
.pointer
= 1;
2325 ptr
->attr
.artificial
= 1;
2326 gfc_set_sym_referenced (ptr
);
2327 gfc_commit_symbol (ptr
);
2330 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2331 stat
->attr
.flavor
= FL_VARIABLE
;
2332 stat
->attr
.artificial
= 1;
2333 stat
->ts
.type
= BT_INTEGER
;
2334 stat
->ts
.kind
= gfc_default_integer_kind
;
2335 gfc_set_sym_referenced (stat
);
2336 gfc_commit_symbol (stat
);
2339 iter
= gfc_get_iterator ();
2340 iter
->var
= gfc_lval_expr_from_sym (idx
);
2341 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2342 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2343 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2344 last_code
->next
= gfc_get_code (EXEC_DO
);
2345 last_code
= last_code
->next
;
2346 last_code
->ext
.iterator
= iter
;
2347 last_code
->block
= gfc_get_code (EXEC_DO
);
2349 /* Offset calculation. */
2350 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2351 byte_stride
, rank
, last_code
->block
,
2355 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2356 + idx * stride, c_ptr), ptr). */
2357 block
->next
= finalization_scalarizer (array
, ptr
,
2358 gfc_lval_expr_from_sym(offset
),
2360 block
= block
->next
;
2362 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2364 if (comp
== derived
->components
&& derived
->attr
.extension
2365 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2368 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2369 stat
, fini_coarray
, &block
, sub_ns
);
2370 if (!last_code
->block
->next
)
2371 last_code
->block
->next
= block
;
2376 /* Call the finalizer of the ancestor. */
2377 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2379 last_code
->next
= gfc_get_code (EXEC_CALL
);
2380 last_code
= last_code
->next
;
2381 last_code
->symtree
= ancestor_wrapper
->symtree
;
2382 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2384 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2385 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2386 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2387 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2388 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2389 last_code
->ext
.actual
->next
->next
->expr
2390 = gfc_lval_expr_from_sym (fini_coarray
);
2393 gfc_free_expr (rank
);
2394 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2395 vtab_final
->ts
.interface
= final
;
2400 /* Add procedure pointers for all type-bound procedures to a vtab. */
2403 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2405 gfc_symbol
* super_type
;
2407 super_type
= gfc_get_derived_super_type (derived
);
2409 if (super_type
&& (super_type
!= derived
))
2411 /* Make sure that the PPCs appear in the same order as in the parent. */
2412 copy_vtab_proc_comps (super_type
, vtype
);
2413 /* Only needed to get the PPC initializers right. */
2414 add_procs_to_declared_vtab (super_type
, vtype
);
2417 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2418 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2420 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2421 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2425 /* Find or generate the symbol for a derived type's vtab. */
2428 gfc_find_derived_vtab (gfc_symbol
*derived
)
2431 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2432 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2433 gfc_gsymbol
*gsym
= NULL
;
2434 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2436 if (derived
->attr
.pdt_template
)
2439 /* Find the top-level namespace. */
2440 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2444 /* If the type is a class container, use the underlying derived type. */
2445 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2446 derived
= gfc_get_derived_super_type (derived
);
2454 /* Find the gsymbol for the module of use associated derived types. */
2455 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2456 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2457 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2461 /* Work in the gsymbol namespace if the top-level namespace is a module.
2462 This ensures that the vtable is unique, which is required since we use
2463 its address in SELECT TYPE. */
2464 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2465 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2470 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2473 get_unique_hashed_string (tname
, derived
);
2474 name
= xasprintf ("__vtab_%s", tname
);
2476 /* Look for the vtab symbol in various namespaces. */
2477 if (gsym
&& gsym
->ns
)
2479 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2484 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2486 gfc_find_symbol (name
, ns
, 0, &vtab
);
2488 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2492 gfc_get_symbol (name
, ns
, &vtab
);
2493 vtab
->ts
.type
= BT_DERIVED
;
2494 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2495 &gfc_current_locus
))
2497 vtab
->attr
.target
= 1;
2498 vtab
->attr
.save
= SAVE_IMPLICIT
;
2499 vtab
->attr
.vtab
= 1;
2500 vtab
->attr
.access
= ACCESS_PUBLIC
;
2501 vtab
->attr
.artificial
= 1;
2502 gfc_set_sym_referenced (vtab
);
2504 name
= xasprintf ("__vtype_%s", tname
);
2506 gfc_find_symbol (name
, ns
, 0, &vtype
);
2510 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2512 gfc_get_symbol (name
, ns
, &vtype
);
2513 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2514 &gfc_current_locus
))
2516 vtype
->attr
.access
= ACCESS_PUBLIC
;
2517 vtype
->attr
.vtype
= 1;
2518 gfc_set_sym_referenced (vtype
);
2520 /* Add component '_hash'. */
2521 if (!gfc_add_component (vtype
, "_hash", &c
))
2523 c
->ts
.type
= BT_INTEGER
;
2525 c
->attr
.access
= ACCESS_PRIVATE
;
2526 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2527 NULL
, derived
->hash_value
);
2529 /* Add component '_size'. */
2530 if (!gfc_add_component (vtype
, "_size", &c
))
2532 c
->ts
.type
= BT_INTEGER
;
2533 c
->ts
.kind
= gfc_size_kind
;
2534 c
->attr
.access
= ACCESS_PRIVATE
;
2535 /* Remember the derived type in ts.u.derived,
2536 so that the correct initializer can be set later on
2537 (in gfc_conv_structure). */
2538 c
->ts
.u
.derived
= derived
;
2539 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2542 /* Add component _extends. */
2543 if (!gfc_add_component (vtype
, "_extends", &c
))
2545 c
->attr
.pointer
= 1;
2546 c
->attr
.access
= ACCESS_PRIVATE
;
2547 if (!derived
->attr
.unlimited_polymorphic
)
2548 parent
= gfc_get_derived_super_type (derived
);
2554 parent_vtab
= gfc_find_derived_vtab (parent
);
2555 c
->ts
.type
= BT_DERIVED
;
2556 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2557 c
->initializer
= gfc_get_expr ();
2558 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2559 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2560 0, &c
->initializer
->symtree
);
2564 c
->ts
.type
= BT_DERIVED
;
2565 c
->ts
.u
.derived
= vtype
;
2566 c
->initializer
= gfc_get_null_expr (NULL
);
2569 if (!derived
->attr
.unlimited_polymorphic
2570 && derived
->components
== NULL
2571 && !derived
->attr
.zero_comp
)
2573 /* At this point an error must have occurred.
2574 Prevent further errors on the vtype components. */
2579 /* Add component _def_init. */
2580 if (!gfc_add_component (vtype
, "_def_init", &c
))
2582 c
->attr
.pointer
= 1;
2583 c
->attr
.artificial
= 1;
2584 c
->attr
.access
= ACCESS_PRIVATE
;
2585 c
->ts
.type
= BT_DERIVED
;
2586 c
->ts
.u
.derived
= derived
;
2587 if (derived
->attr
.unlimited_polymorphic
2588 || derived
->attr
.abstract
)
2589 c
->initializer
= gfc_get_null_expr (NULL
);
2592 /* Construct default initialization variable. */
2594 name
= xasprintf ("__def_init_%s", tname
);
2595 gfc_get_symbol (name
, ns
, &def_init
);
2596 def_init
->attr
.target
= 1;
2597 def_init
->attr
.artificial
= 1;
2598 def_init
->attr
.save
= SAVE_IMPLICIT
;
2599 def_init
->attr
.access
= ACCESS_PUBLIC
;
2600 def_init
->attr
.flavor
= FL_VARIABLE
;
2601 gfc_set_sym_referenced (def_init
);
2602 def_init
->ts
.type
= BT_DERIVED
;
2603 def_init
->ts
.u
.derived
= derived
;
2604 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2606 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2609 /* Add component _copy. */
2610 if (!gfc_add_component (vtype
, "_copy", &c
))
2612 c
->attr
.proc_pointer
= 1;
2613 c
->attr
.access
= ACCESS_PRIVATE
;
2614 c
->attr
.artificial
= 1;
2615 c
->tb
= XCNEW (gfc_typebound_proc
);
2617 if (derived
->attr
.unlimited_polymorphic
2618 || derived
->attr
.abstract
)
2619 c
->initializer
= gfc_get_null_expr (NULL
);
2622 /* Set up namespace. */
2623 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2624 sub_ns
->sibling
= ns
->contained
;
2625 ns
->contained
= sub_ns
;
2626 sub_ns
->resolved
= 1;
2627 /* Set up procedure symbol. */
2629 name
= xasprintf ("__copy_%s", tname
);
2630 gfc_get_symbol (name
, sub_ns
, ©
);
2631 sub_ns
->proc_name
= copy
;
2632 copy
->attr
.flavor
= FL_PROCEDURE
;
2633 copy
->attr
.subroutine
= 1;
2634 copy
->attr
.pure
= 1;
2635 copy
->attr
.artificial
= 1;
2636 copy
->attr
.if_source
= IFSRC_DECL
;
2637 /* This is elemental so that arrays are automatically
2638 treated correctly by the scalarizer. */
2639 copy
->attr
.elemental
= 1;
2640 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2641 copy
->module
= ns
->proc_name
->name
;
2642 gfc_set_sym_referenced (copy
);
2643 /* Set up formal arguments. */
2644 gfc_get_symbol ("src", sub_ns
, &src
);
2645 src
->ts
.type
= BT_DERIVED
;
2646 src
->ts
.u
.derived
= derived
;
2647 src
->attr
.flavor
= FL_VARIABLE
;
2648 src
->attr
.dummy
= 1;
2649 src
->attr
.artificial
= 1;
2650 src
->attr
.intent
= INTENT_IN
;
2651 gfc_set_sym_referenced (src
);
2652 copy
->formal
= gfc_get_formal_arglist ();
2653 copy
->formal
->sym
= src
;
2654 gfc_get_symbol ("dst", sub_ns
, &dst
);
2655 dst
->ts
.type
= BT_DERIVED
;
2656 dst
->ts
.u
.derived
= derived
;
2657 dst
->attr
.flavor
= FL_VARIABLE
;
2658 dst
->attr
.dummy
= 1;
2659 dst
->attr
.artificial
= 1;
2660 dst
->attr
.intent
= INTENT_INOUT
;
2661 gfc_set_sym_referenced (dst
);
2662 copy
->formal
->next
= gfc_get_formal_arglist ();
2663 copy
->formal
->next
->sym
= dst
;
2665 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2666 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2667 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2668 /* Set initializer. */
2669 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2670 c
->ts
.interface
= copy
;
2673 /* Add component _final, which contains a procedure pointer to
2674 a wrapper which handles both the freeing of allocatable
2675 components and the calls to finalization subroutines.
2676 Note: The actual wrapper function can only be generated
2677 at resolution time. */
2678 if (!gfc_add_component (vtype
, "_final", &c
))
2680 c
->attr
.proc_pointer
= 1;
2681 c
->attr
.access
= ACCESS_PRIVATE
;
2682 c
->attr
.artificial
= 1;
2683 c
->tb
= XCNEW (gfc_typebound_proc
);
2685 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2687 /* Add component _deallocate. */
2688 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2690 c
->attr
.proc_pointer
= 1;
2691 c
->attr
.access
= ACCESS_PRIVATE
;
2692 c
->attr
.artificial
= 1;
2693 c
->tb
= XCNEW (gfc_typebound_proc
);
2695 if (derived
->attr
.unlimited_polymorphic
|| derived
->attr
.abstract
2696 || !derived
->attr
.recursive
)
2697 c
->initializer
= gfc_get_null_expr (NULL
);
2700 /* Set up namespace. */
2701 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2703 sub_ns
->sibling
= ns
->contained
;
2704 ns
->contained
= sub_ns
;
2705 sub_ns
->resolved
= 1;
2706 /* Set up procedure symbol. */
2708 name
= xasprintf ("__deallocate_%s", tname
);
2709 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2710 sub_ns
->proc_name
= dealloc
;
2711 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2712 dealloc
->attr
.subroutine
= 1;
2713 dealloc
->attr
.pure
= 1;
2714 dealloc
->attr
.artificial
= 1;
2715 dealloc
->attr
.if_source
= IFSRC_DECL
;
2717 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2718 dealloc
->module
= ns
->proc_name
->name
;
2719 gfc_set_sym_referenced (dealloc
);
2720 /* Set up formal argument. */
2721 gfc_get_symbol ("arg", sub_ns
, &arg
);
2722 arg
->ts
.type
= BT_DERIVED
;
2723 arg
->ts
.u
.derived
= derived
;
2724 arg
->attr
.flavor
= FL_VARIABLE
;
2725 arg
->attr
.dummy
= 1;
2726 arg
->attr
.artificial
= 1;
2727 arg
->attr
.intent
= INTENT_INOUT
;
2728 arg
->attr
.dimension
= 1;
2729 arg
->attr
.allocatable
= 1;
2730 arg
->as
= gfc_get_array_spec();
2731 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2733 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2735 gfc_set_sym_referenced (arg
);
2736 dealloc
->formal
= gfc_get_formal_arglist ();
2737 dealloc
->formal
->sym
= arg
;
2739 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2740 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2741 sub_ns
->code
->ext
.alloc
.list
->expr
2742 = gfc_lval_expr_from_sym (arg
);
2743 /* Set initializer. */
2744 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2745 c
->ts
.interface
= dealloc
;
2748 /* Add procedure pointers for type-bound procedures. */
2749 if (!derived
->attr
.unlimited_polymorphic
)
2750 add_procs_to_declared_vtab (derived
, vtype
);
2754 vtab
->ts
.u
.derived
= vtype
;
2755 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2763 /* It is unexpected to have some symbols added at resolution or code
2764 generation time. We commit the changes in order to keep a clean state. */
2767 gfc_commit_symbol (vtab
);
2769 gfc_commit_symbol (vtype
);
2771 gfc_commit_symbol (def_init
);
2773 gfc_commit_symbol (copy
);
2775 gfc_commit_symbol (src
);
2777 gfc_commit_symbol (dst
);
2779 gfc_commit_symbol (dealloc
);
2781 gfc_commit_symbol (arg
);
2784 gfc_undo_symbols ();
2790 /* Check if a derived type is finalizable. That is the case if it
2791 (1) has a FINAL subroutine or
2792 (2) has a nonpointer nonallocatable component of finalizable type.
2793 If it is finalizable, return an expression containing the
2794 finalization wrapper. */
2797 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2802 /* (1) Check for FINAL subroutines. */
2803 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2806 /* (2) Check for components of finalizable type. */
2807 for (c
= derived
->components
; c
; c
= c
->next
)
2808 if (c
->ts
.type
== BT_DERIVED
2809 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2810 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2816 /* Make sure vtab is generated. */
2817 vtab
= gfc_find_derived_vtab (derived
);
2820 /* Return finalizer expression. */
2821 gfc_component
*final
;
2822 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2823 gcc_assert (strcmp (final
->name
, "_final") == 0);
2824 gcc_assert (final
->initializer
2825 && final
->initializer
->expr_type
!= EXPR_NULL
);
2826 *final_expr
= final
->initializer
;
2833 gfc_may_be_finalized (gfc_typespec ts
)
2835 return (ts
.type
== BT_CLASS
|| (ts
.type
== BT_DERIVED
2836 && ts
.u
.derived
&& gfc_is_finalizable (ts
.u
.derived
, NULL
)));
2840 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2841 needed to support unlimited polymorphism. */
2844 find_intrinsic_vtab (gfc_typespec
*ts
)
2847 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2848 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2850 /* Find the top-level namespace. */
2851 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2857 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2860 /* Encode all types as TYPENAME_KIND_ including especially character
2861 arrays, whose length is now consistently stored in the _len component
2862 of the class-variable. */
2863 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2864 name
= xasprintf ("__vtab_%s", tname
);
2866 /* Look for the vtab symbol in the top-level namespace only. */
2867 gfc_find_symbol (name
, ns
, 0, &vtab
);
2871 gfc_get_symbol (name
, ns
, &vtab
);
2872 vtab
->ts
.type
= BT_DERIVED
;
2873 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2874 &gfc_current_locus
))
2876 vtab
->attr
.target
= 1;
2877 vtab
->attr
.save
= SAVE_IMPLICIT
;
2878 vtab
->attr
.vtab
= 1;
2879 vtab
->attr
.access
= ACCESS_PUBLIC
;
2880 gfc_set_sym_referenced (vtab
);
2882 name
= xasprintf ("__vtype_%s", tname
);
2884 gfc_find_symbol (name
, ns
, 0, &vtype
);
2889 gfc_namespace
*sub_ns
;
2890 gfc_namespace
*contained
;
2894 gfc_get_symbol (name
, ns
, &vtype
);
2895 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2896 &gfc_current_locus
))
2898 vtype
->attr
.access
= ACCESS_PUBLIC
;
2899 vtype
->attr
.vtype
= 1;
2900 gfc_set_sym_referenced (vtype
);
2902 /* Add component '_hash'. */
2903 if (!gfc_add_component (vtype
, "_hash", &c
))
2905 c
->ts
.type
= BT_INTEGER
;
2907 c
->attr
.access
= ACCESS_PRIVATE
;
2908 hash
= gfc_intrinsic_hash_value (ts
);
2909 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2912 /* Add component '_size'. */
2913 if (!gfc_add_component (vtype
, "_size", &c
))
2915 c
->ts
.type
= BT_INTEGER
;
2916 c
->ts
.kind
= gfc_size_kind
;
2917 c
->attr
.access
= ACCESS_PRIVATE
;
2919 /* Build a minimal expression to make use of
2920 target-memory.cc/gfc_element_size for 'size'. Special handling
2921 for character arrays, that are not constant sized: to support
2922 len (str) * kind, only the kind information is stored in the
2924 e
= gfc_get_expr ();
2926 e
->expr_type
= EXPR_VARIABLE
;
2927 if (ts
->type
== BT_CHARACTER
)
2930 gfc_element_size (e
, &e_size
);
2931 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2936 /* Add component _extends. */
2937 if (!gfc_add_component (vtype
, "_extends", &c
))
2939 c
->attr
.pointer
= 1;
2940 c
->attr
.access
= ACCESS_PRIVATE
;
2941 c
->ts
.type
= BT_VOID
;
2942 c
->initializer
= gfc_get_null_expr (NULL
);
2944 /* Add component _def_init. */
2945 if (!gfc_add_component (vtype
, "_def_init", &c
))
2947 c
->attr
.pointer
= 1;
2948 c
->attr
.access
= ACCESS_PRIVATE
;
2949 c
->ts
.type
= BT_VOID
;
2950 c
->initializer
= gfc_get_null_expr (NULL
);
2952 /* Add component _copy. */
2953 if (!gfc_add_component (vtype
, "_copy", &c
))
2955 c
->attr
.proc_pointer
= 1;
2956 c
->attr
.access
= ACCESS_PRIVATE
;
2957 c
->attr
.artificial
= 1;
2958 c
->tb
= XCNEW (gfc_typebound_proc
);
2962 if (ts
->type
!= BT_CHARACTER
)
2963 name
= xasprintf ("__copy_%s", tname
);
2966 /* __copy is always the same for characters.
2967 Check to see if copy function already exists. */
2968 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2969 contained
= ns
->contained
;
2970 for (; contained
; contained
= contained
->sibling
)
2971 if (contained
->proc_name
2972 && strcmp (name
, contained
->proc_name
->name
) == 0)
2974 copy
= contained
->proc_name
;
2979 /* Set up namespace. */
2980 sub_ns
= gfc_get_namespace (ns
, 0);
2981 sub_ns
->sibling
= ns
->contained
;
2982 ns
->contained
= sub_ns
;
2983 sub_ns
->resolved
= 1;
2984 /* Set up procedure symbol. */
2985 gfc_get_symbol (name
, sub_ns
, ©
);
2986 sub_ns
->proc_name
= copy
;
2987 copy
->attr
.flavor
= FL_PROCEDURE
;
2988 copy
->attr
.subroutine
= 1;
2989 copy
->attr
.pure
= 1;
2990 copy
->attr
.if_source
= IFSRC_DECL
;
2991 /* This is elemental so that arrays are automatically
2992 treated correctly by the scalarizer. */
2993 copy
->attr
.elemental
= 1;
2994 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2995 copy
->module
= ns
->proc_name
->name
;
2996 gfc_set_sym_referenced (copy
);
2997 /* Set up formal arguments. */
2998 gfc_get_symbol ("src", sub_ns
, &src
);
2999 src
->ts
.type
= ts
->type
;
3000 src
->ts
.kind
= ts
->kind
;
3001 src
->attr
.flavor
= FL_VARIABLE
;
3002 src
->attr
.dummy
= 1;
3003 src
->attr
.intent
= INTENT_IN
;
3004 gfc_set_sym_referenced (src
);
3005 copy
->formal
= gfc_get_formal_arglist ();
3006 copy
->formal
->sym
= src
;
3007 gfc_get_symbol ("dst", sub_ns
, &dst
);
3008 dst
->ts
.type
= ts
->type
;
3009 dst
->ts
.kind
= ts
->kind
;
3010 dst
->attr
.flavor
= FL_VARIABLE
;
3011 dst
->attr
.dummy
= 1;
3012 dst
->attr
.intent
= INTENT_INOUT
;
3013 gfc_set_sym_referenced (dst
);
3014 copy
->formal
->next
= gfc_get_formal_arglist ();
3015 copy
->formal
->next
->sym
= dst
;
3017 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
3018 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
3019 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
3021 /* Set initializer. */
3022 c
->initializer
= gfc_lval_expr_from_sym (copy
);
3023 c
->ts
.interface
= copy
;
3025 /* Add component _final. */
3026 if (!gfc_add_component (vtype
, "_final", &c
))
3028 c
->attr
.proc_pointer
= 1;
3029 c
->attr
.access
= ACCESS_PRIVATE
;
3030 c
->attr
.artificial
= 1;
3031 c
->tb
= XCNEW (gfc_typebound_proc
);
3033 c
->initializer
= gfc_get_null_expr (NULL
);
3035 vtab
->ts
.u
.derived
= vtype
;
3036 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
3044 /* It is unexpected to have some symbols added at resolution or code
3045 generation time. We commit the changes in order to keep a clean state. */
3048 gfc_commit_symbol (vtab
);
3050 gfc_commit_symbol (vtype
);
3052 gfc_commit_symbol (copy
);
3054 gfc_commit_symbol (src
);
3056 gfc_commit_symbol (dst
);
3059 gfc_undo_symbols ();
3065 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
3068 gfc_find_vtab (gfc_typespec
*ts
)
3075 return gfc_find_derived_vtab (ts
->u
.derived
);
3077 if (ts
->u
.derived
->attr
.is_class
3078 && ts
->u
.derived
->components
3079 && ts
->u
.derived
->components
->ts
.u
.derived
)
3080 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
3084 return find_intrinsic_vtab (ts
);
3089 /* General worker function to find either a type-bound procedure or a
3090 type-bound user operator. */
3093 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
3094 const char* name
, bool noaccess
, bool uop
,
3100 /* Set default to failure. */
3104 if (derived
->f2k_derived
)
3105 /* Set correct symbol-root. */
3106 root
= (uop
? derived
->f2k_derived
->tb_uop_root
3107 : derived
->f2k_derived
->tb_sym_root
);
3111 /* Try to find it in the current type's namespace. */
3112 res
= gfc_find_symtree (root
, name
);
3113 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
3119 if (!noaccess
&& derived
->attr
.use_assoc
3120 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
3123 gfc_error ("%qs of %qs is PRIVATE at %L",
3124 name
, derived
->name
, where
);
3132 /* Otherwise, recurse on parent type if derived is an extension. */
3133 if (derived
->attr
.extension
)
3135 gfc_symbol
* super_type
;
3136 super_type
= gfc_get_derived_super_type (derived
);
3137 gcc_assert (super_type
);
3139 return find_typebound_proc_uop (super_type
, t
, name
,
3140 noaccess
, uop
, where
);
3143 /* Nothing found. */
3148 /* Find a type-bound procedure or user operator by name for a derived-type
3149 (looking recursively through the super-types). */
3152 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
3153 const char* name
, bool noaccess
, locus
* where
)
3155 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
3159 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
3160 const char* name
, bool noaccess
, locus
* where
)
3162 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
3166 /* Find a type-bound intrinsic operator looking recursively through the
3167 super-type hierarchy. */
3170 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
3171 gfc_intrinsic_op op
, bool noaccess
,
3174 gfc_typebound_proc
* res
;
3176 /* Set default to failure. */
3180 /* Try to find it in the current type's namespace. */
3181 if (derived
->f2k_derived
)
3182 res
= derived
->f2k_derived
->tb_op
[op
];
3187 if (res
&& !res
->error
)
3193 if (!noaccess
&& derived
->attr
.use_assoc
3194 && res
->access
== ACCESS_PRIVATE
)
3197 gfc_error ("%qs of %qs is PRIVATE at %L",
3198 gfc_op2string (op
), derived
->name
, where
);
3206 /* Otherwise, recurse on parent type if derived is an extension. */
3207 if (derived
->attr
.extension
)
3209 gfc_symbol
* super_type
;
3210 super_type
= gfc_get_derived_super_type (derived
);
3211 gcc_assert (super_type
);
3213 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3217 /* Nothing found. */
3222 /* Get a typebound-procedure symtree or create and insert it if not yet
3223 present. This is like a very simplified version of gfc_get_sym_tree for
3224 tbp-symtrees rather than regular ones. */
3227 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3229 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3230 return result
? result
: gfc_new_symtree (root
, name
);