1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2024 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 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
269 gfc_add_data_component (e
);
271 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
274 if (ref
->type
!= REF_ARRAY
)
276 ref
->next
= gfc_get_ref ();
278 ref
->type
= REF_ARRAY
;
279 ref
->u
.ar
.type
= AR_FULL
;
285 /* Unfortunately, class array expressions can appear in various conditions;
286 with and without both _data component and an arrayspec. This function
287 deals with that variability. The previous reference to 'ref' is to a
291 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
293 bool no_data
= false;
294 bool with_data
= false;
296 /* An array reference with no _data component. */
297 if (ref
&& ref
->type
== REF_ARRAY
299 && ref
->u
.ar
.type
!= AR_ELEMENT
)
302 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
306 /* Cover cases where _data appears, with or without an array ref. */
307 if (ref
&& ref
->type
== REF_COMPONENT
308 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
316 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
317 && ref
->type
== REF_COMPONENT
318 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
322 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
326 return no_data
|| with_data
;
330 /* Returns true if the expression contains a reference to a class
331 array. Notice that class array elements return false. */
334 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
344 /* Is this a class array object? ie. Is the symbol of type class? */
346 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
347 && CLASS_DATA (e
->symtree
->n
.sym
)
348 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
349 && class_array_ref_detected (e
->ref
, full_array
))
352 /* Or is this a class array component reference? */
353 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
355 if (ref
->type
== REF_COMPONENT
356 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
357 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
358 && class_array_ref_detected (ref
->next
, full_array
))
366 /* Returns true if the expression is a reference to a class
367 scalar. This function is necessary because such expressions
368 can be dressed with a reference to the _data component and so
369 have a type other than BT_CLASS. */
372 gfc_is_class_scalar_expr (gfc_expr
*e
)
379 /* Is this a class object? */
381 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
382 && CLASS_DATA (e
->symtree
->n
.sym
)
383 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
385 || (e
->ref
->type
== REF_COMPONENT
386 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
387 && e
->ref
->next
== NULL
)))
390 /* Or is the final reference BT_CLASS or _data? */
391 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
393 if (ref
->type
== REF_COMPONENT
394 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
395 && CLASS_DATA (ref
->u
.c
.component
)
396 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
397 && (ref
->next
== NULL
398 || (ref
->next
->type
== REF_COMPONENT
399 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
400 && ref
->next
->next
== NULL
)))
408 /* Tells whether the expression E is a reference to a (scalar) class container.
409 Scalar because array class containers usually have an array reference after
410 them, and gfc_fix_class_refs will add the missing "_data" component reference
414 gfc_is_class_container_ref (gfc_expr
*e
)
419 if (e
->expr_type
!= EXPR_VARIABLE
)
420 return e
->ts
.type
== BT_CLASS
;
422 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
427 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
429 if (ref
->type
!= REF_COMPONENT
)
431 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
441 /* Build an initializer for CLASS pointers,
442 initializing the _data component to the init_expr (or NULL) and the _vptr
443 component to the corresponding type (or the declared type, given by ts). */
446 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
450 gfc_symbol
*vtab
= NULL
;
452 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
453 vtab
= gfc_find_vtab (&init_expr
->ts
);
455 vtab
= gfc_find_vtab (ts
);
457 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
458 &ts
->u
.derived
->declared_at
);
461 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
463 gfc_constructor
*ctor
= gfc_constructor_get();
464 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
465 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
466 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
467 ctor
->expr
= gfc_copy_expr (init_expr
);
469 ctor
->expr
= gfc_get_null_expr (NULL
);
470 gfc_constructor_append (&init
->value
.constructor
, ctor
);
477 /* Create a unique string identifier for a derived type, composed of its name
478 and module name. This is used to construct unique names for the class
479 containers and vtab symbols. */
482 get_unique_type_string (gfc_symbol
*derived
)
487 if (derived
->attr
.unlimited_polymorphic
)
490 dt_name
= gfc_dt_upper_string (derived
->name
);
491 len
= strlen (dt_name
) + 2;
492 if (derived
->attr
.unlimited_polymorphic
)
494 string
= XNEWVEC (char, len
);
495 sprintf (string
, "_%s", dt_name
);
497 else if (derived
->module
)
499 string
= XNEWVEC (char, strlen (derived
->module
) + len
);
500 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
502 else if (derived
->ns
->proc_name
)
504 string
= XNEWVEC (char, strlen (derived
->ns
->proc_name
->name
) + len
);
505 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
509 string
= XNEWVEC (char, len
);
510 sprintf (string
, "_%s", dt_name
);
516 /* A relative of 'get_unique_type_string' which makes sure the generated
517 string will not be too long (replacing it by a hash string if needed). */
520 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
522 /* Provide sufficient space to hold "symbol.symbol_symbol". */
524 tmp
= get_unique_type_string (derived
);
525 /* If string is too long, use hash value in hex representation (allow for
526 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
527 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
528 where %d is the (co)rank which can be up to n = 15. */
529 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
531 int h
= gfc_hash_value (derived
);
532 sprintf (string
, "%X", h
);
535 strcpy (string
, tmp
);
540 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
543 gfc_hash_value (gfc_symbol
*sym
)
545 unsigned int hash
= 0;
546 /* Provide sufficient space to hold "symbol.symbol_symbol". */
550 c
= get_unique_type_string (sym
);
553 for (i
= 0; i
< len
; i
++)
554 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
557 /* Return the hash but take the modulus for the sake of module read,
558 even though this slightly increases the chance of collision. */
559 return (hash
% 100000000);
563 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
566 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
568 unsigned int hash
= 0;
569 const char *c
= gfc_typename (ts
, true);
574 for (i
= 0; i
< len
; i
++)
575 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
577 /* Return the hash but take the modulus for the sake of module read,
578 even though this slightly increases the chance of collision. */
579 return (hash
% 100000000);
583 /* Get the _len component from a class/derived object storing a string.
584 For unlimited polymorphic entities a ref to the _data component is available
585 while a ref to the _len component is needed. This routine traverese the
586 ref-chain and strips the last ref to a _data from it replacing it with a
587 ref to the _len component. */
590 gfc_get_len_component (gfc_expr
*e
, int k
)
593 gfc_ref
*ref
, **last
;
595 ptr
= gfc_copy_expr (e
);
597 /* We need to remove the last _data component ref from ptr. */
603 && ref
->type
== REF_COMPONENT
604 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
606 gfc_free_ref_list (ref
);
613 /* And replace if with a ref to the _len component. */
614 gfc_add_len_component (ptr
);
615 if (k
!= ptr
->ts
.kind
)
619 ts
.type
= BT_INTEGER
;
621 gfc_convert_type_warn (ptr
, &ts
, 2, 0);
627 /* Build a polymorphic CLASS entity, using the symbol that comes from
628 build_sym. A CLASS entity is represented by an encapsulating type,
629 which contains the declared type as '_data' component, plus a pointer
630 component '_vptr' which determines the dynamic type. When this CLASS
631 entity is unlimited polymorphic, then also add a component '_len' to
632 store the length of string when that is stored in it. */
636 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
639 char tname
[GFC_MAX_SYMBOL_LEN
+1];
641 gfc_typespec
*orig_ts
= ts
;
650 /* We cannot build the class container now. */
651 if (attr
->class_ok
&& (!ts
->u
.derived
|| !ts
->u
.derived
->components
))
654 /* Class container has already been built with same name. */
656 && ts
->u
.derived
->components
->attr
.dimension
>= attr
->dimension
657 && ts
->u
.derived
->components
->attr
.codimension
>= attr
->codimension
658 && ts
->u
.derived
->components
->attr
.class_pointer
>= attr
->pointer
659 && ts
->u
.derived
->components
->attr
.allocatable
>= attr
->allocatable
)
663 attr
->dimension
|= ts
->u
.derived
->components
->attr
.dimension
;
664 attr
->codimension
|= ts
->u
.derived
->components
->attr
.codimension
;
665 attr
->pointer
|= ts
->u
.derived
->components
->attr
.class_pointer
;
666 attr
->allocatable
|= ts
->u
.derived
->components
->attr
.allocatable
;
667 ts
= &ts
->u
.derived
->components
->ts
;
670 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
671 || attr
->select_type_temporary
|| attr
->associate_var
;
674 /* We cannot build the class container yet. */
677 /* Determine the name of the encapsulating type. */
678 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
683 get_unique_hashed_string (tname
, ts
->u
.derived
);
684 if ((*as
) && attr
->allocatable
)
685 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
686 else if ((*as
) && attr
->pointer
)
687 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
689 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
690 else if (attr
->pointer
)
691 name
= xasprintf ("__class_%s_p", tname
);
692 else if (attr
->allocatable
)
693 name
= xasprintf ("__class_%s_a", tname
);
695 name
= xasprintf ("__class_%s_t", tname
);
697 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
699 /* Find the top-level namespace. */
700 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
705 ns
= ts
->u
.derived
->ns
;
707 /* Although this might seem to be counterintuitive, we can build separate
708 class types with different array specs because the TKR interface checks
709 work on the declared type. All array type other than deferred shape or
710 assumed rank are added to the function namespace to ensure that they
711 are properly distinguished. */
712 if (attr
->dummy
&& !attr
->codimension
&& (*as
)
713 && !((*as
)->type
== AS_DEFERRED
|| (*as
)->type
== AS_ASSUMED_RANK
))
717 gfc_find_symbol (name
, ns
, 0, &fclass
);
718 /* If a local class type with this name already exists, update the
719 name with an index. */
723 sname
= xasprintf ("%s_%d", name
, ++ctr
);
729 gfc_find_symbol (name
, ns
, 0, &fclass
);
734 /* If not there, create a new symbol. */
735 fclass
= gfc_new_symbol (name
, ns
);
736 st
= gfc_new_symtree (&ns
->sym_root
, name
);
738 gfc_set_sym_referenced (fclass
);
740 fclass
->ts
.type
= BT_UNKNOWN
;
741 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
742 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
743 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
744 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
748 /* Add component '_data'. */
749 if (!gfc_add_component (fclass
, "_data", &c
))
752 c
->ts
.type
= BT_DERIVED
;
753 c
->attr
.access
= ACCESS_PRIVATE
;
754 c
->ts
.u
.derived
= ts
->u
.derived
;
755 c
->attr
.class_pointer
= attr
->pointer
;
756 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
757 || attr
->select_type_temporary
;
758 c
->attr
.allocatable
= attr
->allocatable
;
759 c
->attr
.dimension
= attr
->dimension
;
760 c
->attr
.codimension
= attr
->codimension
;
761 c
->attr
.abstract
= fclass
->attr
.abstract
;
763 c
->initializer
= NULL
;
765 /* Add component '_vptr'. */
766 if (!gfc_add_component (fclass
, "_vptr", &c
))
768 c
->ts
.type
= BT_DERIVED
;
769 c
->attr
.access
= ACCESS_PRIVATE
;
772 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
774 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
776 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
778 /* Add component '_len'. Only unlimited polymorphic pointers may
779 have a string assigned to them, i.e., only those need the _len
781 if (!gfc_add_component (fclass
, "_len", &c
))
783 c
->ts
.type
= BT_INTEGER
;
784 c
->ts
.kind
= gfc_charlen_int_kind
;
785 c
->attr
.access
= ACCESS_PRIVATE
;
786 c
->attr
.artificial
= 1;
789 /* Build vtab later. */
790 c
->ts
.u
.derived
= NULL
;
793 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
795 /* Since the extension field is 8 bit wide, we can only have
796 up to 255 extension levels. */
797 if (ts
->u
.derived
->attr
.extension
== 255)
799 gfc_error ("Maximum extension level reached with type %qs at %L",
800 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
804 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
805 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
806 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
809 fclass
->attr
.is_class
= 1;
810 orig_ts
->u
.derived
= fclass
;
811 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
818 /* Add a procedure pointer component to the vtype
819 to represent a specific type-bound procedure. */
822 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
826 if (tb
->non_overridable
&& !tb
->overridden
)
829 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
833 /* Add procedure component. */
834 if (!gfc_add_component (vtype
, name
, &c
))
838 c
->tb
= XCNEW (gfc_typebound_proc
);
841 c
->attr
.procedure
= 1;
842 c
->attr
.proc_pointer
= 1;
843 c
->attr
.flavor
= FL_PROCEDURE
;
844 c
->attr
.access
= ACCESS_PRIVATE
;
845 c
->attr
.external
= 1;
847 c
->attr
.if_source
= IFSRC_IFBODY
;
849 else if (c
->attr
.proc_pointer
&& c
->tb
)
857 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
858 c
->ts
.interface
= ifc
;
860 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
861 c
->attr
.pure
= ifc
->attr
.pure
;
866 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
869 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
875 add_procs_to_declared_vtab1 (st
->left
, vtype
);
878 add_procs_to_declared_vtab1 (st
->right
, vtype
);
880 if (st
->n
.tb
&& !st
->n
.tb
->error
881 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
882 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
886 /* Copy procedure pointers components from the parent type. */
889 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
894 vtab
= gfc_find_derived_vtab (declared
);
896 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
898 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
901 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
906 /* Returns true if any of its nonpointer nonallocatable components or
907 their nonpointer nonallocatable subcomponents has a finalization
911 has_finalizer_component (gfc_symbol
*derived
)
915 for (c
= derived
->components
; c
; c
= c
->next
)
916 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
917 && c
->attr
.flavor
!= FL_PROCEDURE
)
919 if (c
->ts
.u
.derived
->f2k_derived
920 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
923 /* Stop infinite recursion through this function by inhibiting
924 calls when the derived type and that of the component are
926 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
927 && has_finalizer_component (c
->ts
.u
.derived
))
935 comp_is_finalizable (gfc_component
*comp
)
937 if (comp
->attr
.proc_pointer
)
939 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
941 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
942 && (comp
->ts
.u
.derived
->attr
.alloc_comp
943 || has_finalizer_component (comp
->ts
.u
.derived
)
944 || (comp
->ts
.u
.derived
->f2k_derived
945 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
947 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
948 && CLASS_DATA (comp
)->attr
.allocatable
)
955 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
956 neither allocatable nor a pointer but has a finalizer, call it. If it
957 is a nonpointer component with allocatable components or has finalizers, walk
958 them. Either of them is required; other nonallocatables and pointers aren't
960 Note: If the component is allocatable, the DEALLOCATE handling takes care
961 of calling the appropriate finalizers, coarray deregistering, and
962 deallocation of allocatable subcomponents. */
965 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
966 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
967 gfc_namespace
*sub_ns
)
971 gfc_was_finalized
*f
;
973 if (!comp_is_finalizable (comp
))
976 /* If this expression with this component has been finalized
977 already in this namespace, there is nothing to do. */
978 for (f
= sub_ns
->was_finalized
; f
; f
= f
->next
)
980 if (f
->e
== expr
&& f
->c
== comp
)
984 e
= gfc_copy_expr (expr
);
986 e
->ref
= ref
= gfc_get_ref ();
989 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
991 ref
->next
= gfc_get_ref ();
994 ref
->type
= REF_COMPONENT
;
995 ref
->u
.c
.sym
= derived
;
996 ref
->u
.c
.component
= comp
;
999 if (comp
->attr
.dimension
|| comp
->attr
.codimension
1000 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1001 && (CLASS_DATA (comp
)->attr
.dimension
1002 || CLASS_DATA (comp
)->attr
.codimension
)))
1004 ref
->next
= gfc_get_ref ();
1005 ref
->next
->type
= REF_ARRAY
;
1006 ref
->next
->u
.ar
.dimen
= 0;
1007 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
1009 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
1010 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
1013 /* Call DEALLOCATE (comp, stat=ignore). */
1014 if (comp
->attr
.allocatable
1015 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1016 && CLASS_DATA (comp
)->attr
.allocatable
))
1018 gfc_code
*dealloc
, *block
= NULL
;
1020 /* Add IF (fini_coarray). */
1021 if (comp
->attr
.codimension
1022 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1023 && CLASS_DATA (comp
)->attr
.codimension
))
1025 block
= gfc_get_code (EXEC_IF
);
1028 (*code
)->next
= block
;
1029 (*code
) = (*code
)->next
;
1034 block
->block
= gfc_get_code (EXEC_IF
);
1035 block
= block
->block
;
1036 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
1039 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
1041 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
1042 dealloc
->ext
.alloc
.list
->expr
= e
;
1043 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
1045 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
1046 cond
->block
= gfc_get_code (EXEC_IF
);
1047 cond
->block
->expr1
= gfc_get_expr ();
1048 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
1049 cond
->block
->expr1
->where
= gfc_current_locus
;
1050 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
1051 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1052 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1053 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
1054 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
1055 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
1056 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1057 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
1058 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
1059 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
1060 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1061 cond
->block
->next
= dealloc
;
1067 (*code
)->next
= cond
;
1068 (*code
) = (*code
)->next
;
1074 else if (comp
->ts
.type
== BT_DERIVED
1075 && comp
->ts
.u
.derived
->f2k_derived
1076 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1078 /* Call FINAL_WRAPPER (comp); */
1079 gfc_code
*final_wrap
;
1080 gfc_symbol
*vtab
, *byte_stride
;
1081 gfc_expr
*scalar
, *size_expr
, *fini_coarray_expr
;
1084 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1085 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1086 if (strcmp (c
->name
, "_final") == 0)
1091 /* Set scalar argument for storage_size. */
1092 gfc_get_symbol ("comp_byte_stride", sub_ns
, &byte_stride
);
1093 byte_stride
->ts
= e
->ts
;
1094 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1095 byte_stride
->attr
.value
= 1;
1096 byte_stride
->attr
.artificial
= 1;
1097 gfc_set_sym_referenced (byte_stride
);
1098 gfc_commit_symbol (byte_stride
);
1099 scalar
= gfc_lval_expr_from_sym (byte_stride
);
1101 final_wrap
= gfc_get_code (EXEC_CALL
);
1102 final_wrap
->symtree
= c
->initializer
->symtree
;
1103 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1104 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1105 final_wrap
->ext
.actual
->expr
= e
;
1107 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1108 size_expr
= gfc_get_expr ();
1109 size_expr
->where
= gfc_current_locus
;
1110 size_expr
->expr_type
= EXPR_OP
;
1111 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1113 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1114 size_expr
->value
.op
.op1
1115 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1116 "storage_size", gfc_current_locus
, 2,
1118 gfc_get_int_expr (gfc_index_integer_kind
,
1121 /* NUMERIC_STORAGE_SIZE. */
1122 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1123 gfc_character_storage_size
);
1124 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1125 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1127 /* Which provides the argument 'byte_stride'..... */
1128 final_wrap
->ext
.actual
->next
= gfc_get_actual_arglist ();
1129 final_wrap
->ext
.actual
->next
->expr
= size_expr
;
1131 /* ...and last of all the 'fini_coarray' argument. */
1132 fini_coarray_expr
= gfc_lval_expr_from_sym (fini_coarray
);
1133 final_wrap
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1134 final_wrap
->ext
.actual
->next
->next
->expr
= fini_coarray_expr
;
1140 (*code
)->next
= final_wrap
;
1141 (*code
) = (*code
)->next
;
1144 (*code
) = final_wrap
;
1150 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1151 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1156 /* Record that this was finalized already in this namespace. */
1157 f
= sub_ns
->was_finalized
;
1158 sub_ns
->was_finalized
= XCNEW (gfc_was_finalized
);
1159 sub_ns
->was_finalized
->e
= expr
;
1160 sub_ns
->was_finalized
->c
= comp
;
1161 sub_ns
->was_finalized
->next
= f
;
1165 /* Generate code equivalent to
1166 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1167 + offset, c_ptr), ptr). */
1170 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1171 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1174 gfc_expr
*expr
, *expr2
;
1176 /* C_F_POINTER(). */
1177 block
= gfc_get_code (EXEC_CALL
);
1178 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1179 block
->resolved_sym
= block
->symtree
->n
.sym
;
1180 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1181 block
->resolved_sym
->attr
.intrinsic
= 1;
1182 block
->resolved_sym
->attr
.subroutine
= 1;
1183 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1184 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1185 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1186 gfc_commit_symbol (block
->resolved_sym
);
1188 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1189 block
->ext
.actual
= gfc_get_actual_arglist ();
1190 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1191 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1193 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1195 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1197 /* TRANSFER's first argument: C_LOC (array). */
1198 expr
= gfc_get_expr ();
1199 expr
->expr_type
= EXPR_FUNCTION
;
1200 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1201 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1202 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1203 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1204 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1205 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1206 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1207 expr
->value
.function
.actual
->expr
1208 = gfc_lval_expr_from_sym (array
);
1209 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1210 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1211 expr
->ts
.type
= BT_INTEGER
;
1212 expr
->ts
.kind
= gfc_index_integer_kind
;
1213 expr
->where
= gfc_current_locus
;
1216 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1217 gfc_current_locus
, 3, expr
,
1218 gfc_get_int_expr (gfc_index_integer_kind
,
1220 expr2
->ts
.type
= BT_INTEGER
;
1221 expr2
->ts
.kind
= gfc_index_integer_kind
;
1223 /* <array addr> + <offset>. */
1224 block
->ext
.actual
->expr
= gfc_get_expr ();
1225 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1226 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1227 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1228 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1229 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1230 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1232 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1233 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1234 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1235 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1241 /* Calculates the offset to the (idx+1)th element of an array, taking the
1242 stride into account. It generates the code:
1245 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1247 offset = offset * byte_stride. */
1250 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1251 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1252 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1253 gfc_code
*block
, gfc_namespace
*sub_ns
)
1256 gfc_expr
*expr
, *expr2
;
1259 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1260 block
= block
->next
;
1261 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1262 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1265 iter
= gfc_get_iterator ();
1266 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1267 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1268 iter
->end
= gfc_copy_expr (rank
);
1269 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1270 block
->next
= gfc_get_code (EXEC_DO
);
1271 block
= block
->next
;
1272 block
->ext
.iterator
= iter
;
1273 block
->block
= gfc_get_code (EXEC_DO
);
1275 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1278 /* mod (idx, sizes(idx2)). */
1279 expr
= gfc_lval_expr_from_sym (sizes
);
1280 expr
->ref
= gfc_get_ref ();
1281 expr
->ref
->type
= REF_ARRAY
;
1282 expr
->ref
->u
.ar
.as
= sizes
->as
;
1283 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1284 expr
->ref
->u
.ar
.dimen
= 1;
1285 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1286 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1287 expr
->where
= sizes
->declared_at
;
1289 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1290 gfc_current_locus
, 2,
1291 gfc_lval_expr_from_sym (idx
), expr
);
1294 /* (...) / sizes(idx2-1). */
1295 expr2
= gfc_get_expr ();
1296 expr2
->expr_type
= EXPR_OP
;
1297 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1298 expr2
->value
.op
.op1
= expr
;
1299 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1300 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1301 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1302 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1303 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1304 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1305 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1306 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1307 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1308 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1309 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1310 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1311 = gfc_lval_expr_from_sym (idx2
);
1312 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1313 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1314 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1315 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1316 expr2
->ts
= idx
->ts
;
1317 expr2
->where
= gfc_current_locus
;
1319 /* ... * strides(idx2). */
1320 expr
= gfc_get_expr ();
1321 expr
->expr_type
= EXPR_OP
;
1322 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1323 expr
->value
.op
.op1
= expr2
;
1324 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1325 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1326 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1327 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1328 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1329 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1330 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1331 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1333 expr
->where
= gfc_current_locus
;
1335 /* offset = offset + ... */
1336 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1337 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1338 block
->block
->next
->expr2
= gfc_get_expr ();
1339 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1340 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1341 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1342 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1343 block
->block
->next
->expr2
->ts
= idx
->ts
;
1344 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1346 /* After the loop: offset = offset * byte_stride. */
1347 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1348 block
= block
->next
;
1349 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1350 block
->expr2
= gfc_get_expr ();
1351 block
->expr2
->expr_type
= EXPR_OP
;
1352 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1353 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1354 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1355 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1356 block
->expr2
->where
= gfc_current_locus
;
1361 /* Insert code of the following form:
1364 integer(c_intptr_t) :: i
1366 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1367 && (is_contiguous || !final_rank3->attr.contiguous
1368 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1369 || 0 == STORAGE_SIZE (array)) then
1370 call final_rank3 (array)
1373 integer(c_intptr_t) :: offset, j
1374 type(t) :: tmp(shape (array))
1376 do i = 0, size (array)-1
1377 offset = obtain_offset(i, strides, sizes, byte_stride)
1378 addr = transfer (c_loc (array), addr) + offset
1379 call c_f_pointer (transfer (addr, cptr), ptr)
1381 addr = transfer (c_loc (tmp), addr)
1382 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1383 call c_f_pointer (transfer (addr, cptr), ptr2)
1386 call final_rank3 (tmp)
1392 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1393 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1394 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1396 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1397 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1398 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1399 gfc_namespace
*sub_ns
)
1401 gfc_symbol
*tmp_array
, *ptr2
;
1402 gfc_expr
*size_expr
, *offset2
, *expr
;
1408 block
->next
= gfc_get_code (EXEC_IF
);
1409 block
= block
->next
;
1411 block
->block
= gfc_get_code (EXEC_IF
);
1412 block
= block
->block
;
1414 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1415 size_expr
= gfc_get_expr ();
1416 size_expr
->where
= gfc_current_locus
;
1417 size_expr
->expr_type
= EXPR_OP
;
1418 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1420 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1421 size_expr
->value
.op
.op1
1422 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1423 "storage_size", gfc_current_locus
, 2,
1424 gfc_lval_expr_from_sym (array
),
1425 gfc_get_int_expr (gfc_index_integer_kind
,
1428 /* NUMERIC_STORAGE_SIZE. */
1429 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1430 gfc_character_storage_size
);
1431 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1432 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1434 /* IF condition: (stride == size_expr
1435 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1437 || 0 == size_expr. */
1438 block
->expr1
= gfc_get_expr ();
1439 block
->expr1
->ts
.type
= BT_LOGICAL
;
1440 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1441 block
->expr1
->expr_type
= EXPR_OP
;
1442 block
->expr1
->where
= gfc_current_locus
;
1444 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1446 /* byte_stride == size_expr */
1447 expr
= gfc_get_expr ();
1448 expr
->ts
.type
= BT_LOGICAL
;
1449 expr
->ts
.kind
= gfc_default_logical_kind
;
1450 expr
->expr_type
= EXPR_OP
;
1451 expr
->where
= gfc_current_locus
;
1452 expr
->value
.op
.op
= INTRINSIC_EQ
;
1454 = gfc_lval_expr_from_sym (byte_stride
);
1455 expr
->value
.op
.op2
= size_expr
;
1457 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1458 add is_contiguous check. */
1460 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1461 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1464 expr2
= gfc_get_expr ();
1465 expr2
->ts
.type
= BT_LOGICAL
;
1466 expr2
->ts
.kind
= gfc_default_logical_kind
;
1467 expr2
->expr_type
= EXPR_OP
;
1468 expr2
->where
= gfc_current_locus
;
1469 expr2
->value
.op
.op
= INTRINSIC_AND
;
1470 expr2
->value
.op
.op1
= expr
;
1471 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1475 block
->expr1
->value
.op
.op1
= expr
;
1477 /* 0 == size_expr */
1478 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1479 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1480 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1481 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1482 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1483 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1484 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1485 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1486 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1488 /* IF body: call final subroutine. */
1489 block
->next
= gfc_get_code (EXEC_CALL
);
1490 block
->next
->symtree
= fini
->proc_tree
;
1491 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1492 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1493 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1497 block
->block
= gfc_get_code (EXEC_IF
);
1498 block
= block
->block
;
1500 /* BLOCK ... END BLOCK. */
1501 block
->next
= gfc_get_code (EXEC_BLOCK
);
1502 block
= block
->next
;
1504 ns
= gfc_build_block_ns (sub_ns
);
1505 block
->ext
.block
.ns
= ns
;
1506 block
->ext
.block
.assoc
= NULL
;
1508 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1509 ptr2
->ts
.type
= BT_DERIVED
;
1510 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1511 ptr2
->attr
.flavor
= FL_VARIABLE
;
1512 ptr2
->attr
.pointer
= 1;
1513 ptr2
->attr
.artificial
= 1;
1514 gfc_set_sym_referenced (ptr2
);
1515 gfc_commit_symbol (ptr2
);
1517 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1518 tmp_array
->ts
.type
= BT_DERIVED
;
1519 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1520 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1521 tmp_array
->attr
.dimension
= 1;
1522 tmp_array
->attr
.artificial
= 1;
1523 tmp_array
->as
= gfc_get_array_spec();
1524 tmp_array
->attr
.intent
= INTENT_INOUT
;
1525 tmp_array
->as
->type
= AS_EXPLICIT
;
1526 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1528 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1530 gfc_expr
*shape_expr
;
1531 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1533 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1535 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1536 gfc_current_locus
, 3,
1537 gfc_lval_expr_from_sym (array
),
1538 gfc_get_int_expr (gfc_default_integer_kind
,
1540 gfc_get_int_expr (gfc_default_integer_kind
,
1542 gfc_index_integer_kind
));
1543 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1544 tmp_array
->as
->upper
[i
] = shape_expr
;
1546 gfc_set_sym_referenced (tmp_array
);
1547 gfc_commit_symbol (tmp_array
);
1550 iter
= gfc_get_iterator ();
1551 iter
->var
= gfc_lval_expr_from_sym (idx
);
1552 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1553 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1554 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1556 block
= gfc_get_code (EXEC_DO
);
1558 block
->ext
.iterator
= iter
;
1559 block
->block
= gfc_get_code (EXEC_DO
);
1561 /* Offset calculation for the new array: idx * size of type (in bytes). */
1562 offset2
= gfc_get_expr ();
1563 offset2
->expr_type
= EXPR_OP
;
1564 offset2
->where
= gfc_current_locus
;
1565 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1566 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1567 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1568 offset2
->ts
= byte_stride
->ts
;
1570 /* Offset calculation of "array". */
1571 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1572 byte_stride
, rank
, block
->block
, sub_ns
);
1575 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1576 + idx * stride, c_ptr), ptr). */
1577 block2
->next
= finalization_scalarizer (array
, ptr
,
1578 gfc_lval_expr_from_sym (offset
),
1580 block2
= block2
->next
;
1581 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1582 block2
= block2
->next
;
1585 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1586 block2
= block2
->next
;
1587 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1588 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1590 /* Call now the user's final subroutine. */
1591 block
->next
= gfc_get_code (EXEC_CALL
);
1592 block
= block
->next
;
1593 block
->symtree
= fini
->proc_tree
;
1594 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1595 block
->ext
.actual
= gfc_get_actual_arglist ();
1596 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1598 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1604 iter
= gfc_get_iterator ();
1605 iter
->var
= gfc_lval_expr_from_sym (idx
);
1606 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1607 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1608 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1610 block
->next
= gfc_get_code (EXEC_DO
);
1611 block
= block
->next
;
1612 block
->ext
.iterator
= iter
;
1613 block
->block
= gfc_get_code (EXEC_DO
);
1615 /* Offset calculation of "array". */
1616 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1617 byte_stride
, rank
, block
->block
, sub_ns
);
1620 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1621 + offset, c_ptr), ptr). */
1622 block2
->next
= finalization_scalarizer (array
, ptr
,
1623 gfc_lval_expr_from_sym (offset
),
1625 block2
= block2
->next
;
1626 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1627 gfc_copy_expr (offset2
), sub_ns
);
1628 block2
= block2
->next
;
1631 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1632 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1633 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1637 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1638 derived type "derived". The function first calls the appropriate FINAL
1639 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1640 components (but not the inherited ones). Last, it calls the wrapper
1641 subroutine of the parent. The generated wrapper procedure takes as argument
1642 an assumed-rank array.
1643 If neither allocatable components nor FINAL subroutines exists, the vtab
1644 will contain a NULL pointer.
1645 The generated function has the form
1646 _final(assumed-rank array, stride, skip_corarray)
1647 where the array has to be contiguous (except of the lowest dimension). The
1648 stride (in bytes) is used to allow different sizes for ancestor types by
1649 skipping over the additionally added components in the scalarizer. If
1650 "fini_coarray" is false, coarray components are not finalized to allow for
1651 the correct semantic with intrinsic assignment. */
1654 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1655 const char *tname
, gfc_component
*vtab_final
)
1657 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1658 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1659 gfc_component
*comp
;
1660 gfc_namespace
*sub_ns
;
1661 gfc_code
*last_code
, *block
;
1663 bool finalizable_comp
= false;
1664 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1667 if (derived
->attr
.unlimited_polymorphic
)
1669 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1673 /* Search for the ancestor's finalizers. */
1674 if (derived
->attr
.extension
&& derived
->components
1675 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1676 || has_finalizer_component (derived
)))
1679 gfc_component
*comp
;
1681 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1682 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1683 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1685 ancestor_wrapper
= comp
->initializer
;
1690 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1691 components: Return a NULL() expression; we defer this a bit to have
1692 an interface declaration. */
1693 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1694 && !derived
->attr
.alloc_comp
1695 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1696 && !has_finalizer_component (derived
))
1698 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1699 gcc_assert (vtab_final
->ts
.interface
== NULL
);
1703 /* Check whether there are new allocatable components. */
1704 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1706 if (comp
== derived
->components
&& derived
->attr
.extension
1707 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1710 finalizable_comp
|= comp_is_finalizable (comp
);
1713 /* If there is no new finalizer and no new allocatable, return with
1714 an expr to the ancestor's one. */
1715 if (!finalizable_comp
1716 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1718 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1719 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1720 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1721 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1725 /* We now create a wrapper, which does the following:
1726 1. Call the suitable finalization subroutine for this type
1727 2. Loop over all noninherited allocatable components and noninherited
1728 components with allocatable components and DEALLOCATE those; this will
1729 take care of finalizers, coarray deregistering and allocatable
1731 3. Call the ancestor's finalizer. */
1733 /* Declare the wrapper function; it takes an assumed-rank array
1734 and a VALUE logical as arguments. */
1736 /* Set up the namespace. */
1737 sub_ns
= gfc_get_namespace (ns
, 0);
1738 sub_ns
->sibling
= ns
->contained
;
1739 ns
->contained
= sub_ns
;
1740 sub_ns
->resolved
= 1;
1742 /* Set up the procedure symbol. */
1743 name
= xasprintf ("__final_%s", tname
);
1744 gfc_get_symbol (name
, sub_ns
, &final
);
1745 sub_ns
->proc_name
= final
;
1746 final
->attr
.flavor
= FL_PROCEDURE
;
1747 final
->attr
.function
= 1;
1748 final
->attr
.pure
= 0;
1749 final
->attr
.recursive
= 1;
1750 final
->result
= final
;
1751 final
->ts
.type
= BT_INTEGER
;
1753 final
->attr
.artificial
= 1;
1754 final
->attr
.always_explicit
= 1;
1755 final
->attr
.if_source
= IFSRC_DECL
;
1756 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1757 final
->module
= ns
->proc_name
->name
;
1758 gfc_set_sym_referenced (final
);
1759 gfc_commit_symbol (final
);
1761 /* Set up formal argument. */
1762 gfc_get_symbol ("array", sub_ns
, &array
);
1763 array
->ts
.type
= BT_DERIVED
;
1764 array
->ts
.u
.derived
= derived
;
1765 array
->attr
.flavor
= FL_VARIABLE
;
1766 array
->attr
.dummy
= 1;
1767 array
->attr
.contiguous
= 1;
1768 array
->attr
.dimension
= 1;
1769 array
->attr
.artificial
= 1;
1770 array
->as
= gfc_get_array_spec();
1771 array
->as
->type
= AS_ASSUMED_RANK
;
1772 array
->as
->rank
= -1;
1773 array
->attr
.intent
= INTENT_INOUT
;
1774 gfc_set_sym_referenced (array
);
1775 final
->formal
= gfc_get_formal_arglist ();
1776 final
->formal
->sym
= array
;
1777 gfc_commit_symbol (array
);
1779 /* Set up formal argument. */
1780 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1781 byte_stride
->ts
.type
= BT_INTEGER
;
1782 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1783 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1784 byte_stride
->attr
.dummy
= 1;
1785 byte_stride
->attr
.value
= 1;
1786 byte_stride
->attr
.artificial
= 1;
1787 gfc_set_sym_referenced (byte_stride
);
1788 final
->formal
->next
= gfc_get_formal_arglist ();
1789 final
->formal
->next
->sym
= byte_stride
;
1790 gfc_commit_symbol (byte_stride
);
1792 /* Set up formal argument. */
1793 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1794 fini_coarray
->ts
.type
= BT_LOGICAL
;
1795 fini_coarray
->ts
.kind
= 1;
1796 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1797 fini_coarray
->attr
.dummy
= 1;
1798 fini_coarray
->attr
.value
= 1;
1799 fini_coarray
->attr
.artificial
= 1;
1800 gfc_set_sym_referenced (fini_coarray
);
1801 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1802 final
->formal
->next
->next
->sym
= fini_coarray
;
1803 gfc_commit_symbol (fini_coarray
);
1805 /* Local variables. */
1807 gfc_get_symbol ("idx", sub_ns
, &idx
);
1808 idx
->ts
.type
= BT_INTEGER
;
1809 idx
->ts
.kind
= gfc_index_integer_kind
;
1810 idx
->attr
.flavor
= FL_VARIABLE
;
1811 idx
->attr
.artificial
= 1;
1812 gfc_set_sym_referenced (idx
);
1813 gfc_commit_symbol (idx
);
1815 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1816 idx2
->ts
.type
= BT_INTEGER
;
1817 idx2
->ts
.kind
= gfc_index_integer_kind
;
1818 idx2
->attr
.flavor
= FL_VARIABLE
;
1819 idx2
->attr
.artificial
= 1;
1820 gfc_set_sym_referenced (idx2
);
1821 gfc_commit_symbol (idx2
);
1823 gfc_get_symbol ("offset", sub_ns
, &offset
);
1824 offset
->ts
.type
= BT_INTEGER
;
1825 offset
->ts
.kind
= gfc_index_integer_kind
;
1826 offset
->attr
.flavor
= FL_VARIABLE
;
1827 offset
->attr
.artificial
= 1;
1828 gfc_set_sym_referenced (offset
);
1829 gfc_commit_symbol (offset
);
1831 /* Create RANK expression. */
1832 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1833 gfc_current_locus
, 1,
1834 gfc_lval_expr_from_sym (array
));
1835 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1836 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1838 /* Create is_contiguous variable. */
1839 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1840 is_contiguous
->ts
.type
= BT_LOGICAL
;
1841 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1842 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1843 is_contiguous
->attr
.artificial
= 1;
1844 gfc_set_sym_referenced (is_contiguous
);
1845 gfc_commit_symbol (is_contiguous
);
1847 /* Create "sizes(0..rank)" variable, which contains the multiplied
1848 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1849 sizes(2) = sizes(1) * extent(dim=2) etc. */
1850 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1851 sizes
->ts
.type
= BT_INTEGER
;
1852 sizes
->ts
.kind
= gfc_index_integer_kind
;
1853 sizes
->attr
.flavor
= FL_VARIABLE
;
1854 sizes
->attr
.dimension
= 1;
1855 sizes
->attr
.artificial
= 1;
1856 sizes
->as
= gfc_get_array_spec();
1857 sizes
->attr
.intent
= INTENT_INOUT
;
1858 sizes
->as
->type
= AS_EXPLICIT
;
1859 sizes
->as
->rank
= 1;
1860 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1861 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1862 gfc_set_sym_referenced (sizes
);
1863 gfc_commit_symbol (sizes
);
1865 /* Create "strides(1..rank)" variable, which contains the strides per
1867 gfc_get_symbol ("strides", sub_ns
, &strides
);
1868 strides
->ts
.type
= BT_INTEGER
;
1869 strides
->ts
.kind
= gfc_index_integer_kind
;
1870 strides
->attr
.flavor
= FL_VARIABLE
;
1871 strides
->attr
.dimension
= 1;
1872 strides
->attr
.artificial
= 1;
1873 strides
->as
= gfc_get_array_spec();
1874 strides
->attr
.intent
= INTENT_INOUT
;
1875 strides
->as
->type
= AS_EXPLICIT
;
1876 strides
->as
->rank
= 1;
1877 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1878 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1879 gfc_set_sym_referenced (strides
);
1880 gfc_commit_symbol (strides
);
1883 /* Set return value to 0. */
1884 last_code
= gfc_get_code (EXEC_ASSIGN
);
1885 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1886 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1887 sub_ns
->code
= last_code
;
1889 /* Set: is_contiguous = .true. */
1890 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1891 last_code
= last_code
->next
;
1892 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1893 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1894 &gfc_current_locus
, true);
1896 /* Set: sizes(0) = 1. */
1897 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1898 last_code
= last_code
->next
;
1899 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1900 last_code
->expr1
->ref
= gfc_get_ref ();
1901 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1902 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1903 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1904 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1905 last_code
->expr1
->ref
->u
.ar
.start
[0]
1906 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1907 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1908 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1912 strides(idx) = _F._stride (array, dim=idx)
1913 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1914 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1918 iter
= gfc_get_iterator ();
1919 iter
->var
= gfc_lval_expr_from_sym (idx
);
1920 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1921 iter
->end
= gfc_copy_expr (rank
);
1922 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1923 last_code
->next
= gfc_get_code (EXEC_DO
);
1924 last_code
= last_code
->next
;
1925 last_code
->ext
.iterator
= iter
;
1926 last_code
->block
= gfc_get_code (EXEC_DO
);
1928 /* strides(idx) = _F._stride(array,dim=idx). */
1929 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1930 block
= last_code
->block
->next
;
1932 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1933 block
->expr1
->ref
= gfc_get_ref ();
1934 block
->expr1
->ref
->type
= REF_ARRAY
;
1935 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1936 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1937 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1938 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1939 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1941 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1942 gfc_current_locus
, 2,
1943 gfc_lval_expr_from_sym (array
),
1944 gfc_lval_expr_from_sym (idx
));
1946 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1947 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1948 block
= block
->next
;
1950 /* sizes(idx) = ... */
1951 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1952 block
->expr1
->ref
= gfc_get_ref ();
1953 block
->expr1
->ref
->type
= REF_ARRAY
;
1954 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1955 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1956 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1957 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1958 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1960 block
->expr2
= gfc_get_expr ();
1961 block
->expr2
->expr_type
= EXPR_OP
;
1962 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1963 block
->expr2
->where
= gfc_current_locus
;
1966 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1967 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1968 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1969 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1970 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1971 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1972 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1973 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1974 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1975 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1976 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1977 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1978 = gfc_lval_expr_from_sym (idx
);
1979 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1980 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1981 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1982 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1984 /* size(array, dim=idx, kind=index_kind). */
1985 block
->expr2
->value
.op
.op2
1986 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1987 gfc_current_locus
, 3,
1988 gfc_lval_expr_from_sym (array
),
1989 gfc_lval_expr_from_sym (idx
),
1990 gfc_get_int_expr (gfc_index_integer_kind
,
1992 gfc_index_integer_kind
));
1993 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1994 block
->expr2
->ts
= idx
->ts
;
1996 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1997 block
->next
= gfc_get_code (EXEC_IF
);
1998 block
= block
->next
;
2000 block
->block
= gfc_get_code (EXEC_IF
);
2001 block
= block
->block
;
2003 /* if condition: strides(idx) /= sizes(idx-1). */
2004 block
->expr1
= gfc_get_expr ();
2005 block
->expr1
->ts
.type
= BT_LOGICAL
;
2006 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
2007 block
->expr1
->expr_type
= EXPR_OP
;
2008 block
->expr1
->where
= gfc_current_locus
;
2009 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
2011 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
2012 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
2013 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2014 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2015 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2016 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2017 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
2018 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
2020 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
2021 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
2022 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
2023 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
2024 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
2025 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
2026 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2027 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
2028 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
2029 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
2030 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
2031 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
2032 = gfc_lval_expr_from_sym (idx
);
2033 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
2034 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2035 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
2036 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
2038 /* if body: is_contiguous = .false. */
2039 block
->next
= gfc_get_code (EXEC_ASSIGN
);
2040 block
= block
->next
;
2041 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
2042 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
2043 &gfc_current_locus
, false);
2045 /* Obtain the size (number of elements) of "array" MINUS ONE,
2046 which is used in the scalarization. */
2047 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
2048 nelem
->ts
.type
= BT_INTEGER
;
2049 nelem
->ts
.kind
= gfc_index_integer_kind
;
2050 nelem
->attr
.flavor
= FL_VARIABLE
;
2051 nelem
->attr
.artificial
= 1;
2052 gfc_set_sym_referenced (nelem
);
2053 gfc_commit_symbol (nelem
);
2055 /* nelem = sizes (rank) - 1. */
2056 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
2057 last_code
= last_code
->next
;
2059 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
2061 last_code
->expr2
= gfc_get_expr ();
2062 last_code
->expr2
->expr_type
= EXPR_OP
;
2063 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
2064 last_code
->expr2
->value
.op
.op2
2065 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2066 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
2067 last_code
->expr2
->where
= gfc_current_locus
;
2069 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
2070 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2071 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2072 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2073 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2074 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2075 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
2076 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2078 /* Call final subroutines. We now generate code like:
2080 integer, pointer :: ptr
2082 integer(c_intptr_t) :: i, addr
2084 select case (rank (array))
2086 ! If needed, the array is packed
2087 call final_rank3 (array)
2089 do i = 0, size (array)-1
2090 addr = transfer (c_loc (array), addr) + i * stride
2091 call c_f_pointer (transfer (addr, cptr), ptr)
2092 call elemental_final (ptr)
2096 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2098 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2100 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
2101 ptr
->ts
.type
= BT_DERIVED
;
2102 ptr
->ts
.u
.derived
= derived
;
2103 ptr
->attr
.flavor
= FL_VARIABLE
;
2104 ptr
->attr
.pointer
= 1;
2105 ptr
->attr
.artificial
= 1;
2106 gfc_set_sym_referenced (ptr
);
2107 gfc_commit_symbol (ptr
);
2109 fini
= derived
->f2k_derived
->finalizers
;
2111 /* Assumed rank finalizers can be called directly. The call takes care
2112 of setting up the descriptor. resolve_finalizers has already checked
2113 that this is the only finalizer for this kind/type (F2018: C790). */
2114 if (fini
->proc_tree
&& fini
->proc_tree
->n
.sym
->formal
->sym
->as
2115 && fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
== AS_ASSUMED_RANK
)
2117 last_code
->next
= gfc_get_code (EXEC_CALL
);
2118 last_code
->next
->symtree
= fini
->proc_tree
;
2119 last_code
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2120 last_code
->next
->ext
.actual
= gfc_get_actual_arglist ();
2121 last_code
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2123 last_code
= last_code
->next
;
2124 goto finish_assumed_rank
;
2127 /* SELECT CASE (RANK (array)). */
2128 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2129 last_code
= last_code
->next
;
2130 last_code
->expr1
= gfc_copy_expr (rank
);
2134 for (; fini
; fini
= fini
->next
)
2136 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2137 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2143 /* CASE (fini_rank). */
2146 block
->block
= gfc_get_code (EXEC_SELECT
);
2147 block
= block
->block
;
2151 block
= gfc_get_code (EXEC_SELECT
);
2152 last_code
->block
= block
;
2154 block
->ext
.block
.case_list
= gfc_get_case ();
2155 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2156 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2157 block
->ext
.block
.case_list
->low
2158 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2159 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2161 block
->ext
.block
.case_list
->low
2162 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2163 block
->ext
.block
.case_list
->high
2164 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2166 /* CALL fini_rank (array) - possibly with packing. */
2167 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2168 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2169 idx
, ptr
, nelem
, strides
,
2170 sizes
, idx2
, offset
, is_contiguous
,
2174 block
->next
= gfc_get_code (EXEC_CALL
);
2175 block
->next
->symtree
= fini
->proc_tree
;
2176 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2177 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2178 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2182 /* Elemental call - scalarized. */
2188 block
->block
= gfc_get_code (EXEC_SELECT
);
2189 block
= block
->block
;
2193 block
= gfc_get_code (EXEC_SELECT
);
2194 last_code
->block
= block
;
2196 block
->ext
.block
.case_list
= gfc_get_case ();
2199 iter
= gfc_get_iterator ();
2200 iter
->var
= gfc_lval_expr_from_sym (idx
);
2201 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2202 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2203 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2204 block
->next
= gfc_get_code (EXEC_DO
);
2205 block
= block
->next
;
2206 block
->ext
.iterator
= iter
;
2207 block
->block
= gfc_get_code (EXEC_DO
);
2209 /* Offset calculation. */
2210 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2211 byte_stride
, rank
, block
->block
,
2215 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2216 + offset, c_ptr), ptr). */
2218 = finalization_scalarizer (array
, ptr
,
2219 gfc_lval_expr_from_sym (offset
),
2221 block
= block
->next
;
2223 /* CALL final_elemental (array). */
2224 block
->next
= gfc_get_code (EXEC_CALL
);
2225 block
= block
->next
;
2226 block
->symtree
= fini_elem
->proc_tree
;
2227 block
->resolved_sym
= fini_elem
->proc_sym
;
2228 block
->ext
.actual
= gfc_get_actual_arglist ();
2229 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2233 finish_assumed_rank
:
2235 /* Finalize and deallocate allocatable components. The same manual
2236 scalarization is used as above. */
2238 if (finalizable_comp
)
2241 gfc_code
*block
= NULL
;
2245 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2246 ptr
->ts
.type
= BT_DERIVED
;
2247 ptr
->ts
.u
.derived
= derived
;
2248 ptr
->attr
.flavor
= FL_VARIABLE
;
2249 ptr
->attr
.pointer
= 1;
2250 ptr
->attr
.artificial
= 1;
2251 gfc_set_sym_referenced (ptr
);
2252 gfc_commit_symbol (ptr
);
2255 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2256 stat
->attr
.flavor
= FL_VARIABLE
;
2257 stat
->attr
.artificial
= 1;
2258 stat
->ts
.type
= BT_INTEGER
;
2259 stat
->ts
.kind
= gfc_default_integer_kind
;
2260 gfc_set_sym_referenced (stat
);
2261 gfc_commit_symbol (stat
);
2264 iter
= gfc_get_iterator ();
2265 iter
->var
= gfc_lval_expr_from_sym (idx
);
2266 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2267 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2268 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2269 last_code
->next
= gfc_get_code (EXEC_DO
);
2270 last_code
= last_code
->next
;
2271 last_code
->ext
.iterator
= iter
;
2272 last_code
->block
= gfc_get_code (EXEC_DO
);
2274 /* Offset calculation. */
2275 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2276 byte_stride
, rank
, last_code
->block
,
2280 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2281 + idx * stride, c_ptr), ptr). */
2282 block
->next
= finalization_scalarizer (array
, ptr
,
2283 gfc_lval_expr_from_sym(offset
),
2285 block
= block
->next
;
2287 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2289 if (comp
== derived
->components
&& derived
->attr
.extension
2290 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2293 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2294 stat
, fini_coarray
, &block
, sub_ns
);
2295 if (!last_code
->block
->next
)
2296 last_code
->block
->next
= block
;
2301 /* Call the finalizer of the ancestor. */
2302 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2304 last_code
->next
= gfc_get_code (EXEC_CALL
);
2305 last_code
= last_code
->next
;
2306 last_code
->symtree
= ancestor_wrapper
->symtree
;
2307 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2309 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2310 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2311 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2312 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2313 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2314 last_code
->ext
.actual
->next
->next
->expr
2315 = gfc_lval_expr_from_sym (fini_coarray
);
2318 gfc_free_expr (rank
);
2319 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2320 vtab_final
->ts
.interface
= final
;
2325 /* Add procedure pointers for all type-bound procedures to a vtab. */
2328 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2330 gfc_symbol
* super_type
;
2332 super_type
= gfc_get_derived_super_type (derived
);
2334 if (super_type
&& (super_type
!= derived
))
2336 /* Make sure that the PPCs appear in the same order as in the parent. */
2337 copy_vtab_proc_comps (super_type
, vtype
);
2338 /* Only needed to get the PPC initializers right. */
2339 add_procs_to_declared_vtab (super_type
, vtype
);
2342 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2343 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2345 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2346 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2350 /* Find or generate the symbol for a derived type's vtab. */
2353 gfc_find_derived_vtab (gfc_symbol
*derived
)
2356 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2357 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2358 gfc_gsymbol
*gsym
= NULL
;
2359 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2361 if (derived
->attr
.pdt_template
)
2364 /* Find the top-level namespace. */
2365 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2369 /* If the type is a class container, use the underlying derived type. */
2370 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2371 derived
= gfc_get_derived_super_type (derived
);
2379 /* Find the gsymbol for the module of use associated derived types. */
2380 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2381 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2382 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2386 /* Work in the gsymbol namespace if the top-level namespace is a module.
2387 This ensures that the vtable is unique, which is required since we use
2388 its address in SELECT TYPE. */
2389 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2390 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2395 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2398 get_unique_hashed_string (tname
, derived
);
2399 name
= xasprintf ("__vtab_%s", tname
);
2401 /* Look for the vtab symbol in various namespaces. */
2402 if (gsym
&& gsym
->ns
)
2404 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2409 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2411 gfc_find_symbol (name
, ns
, 0, &vtab
);
2413 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2417 gfc_get_symbol (name
, ns
, &vtab
);
2418 vtab
->ts
.type
= BT_DERIVED
;
2419 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2420 &gfc_current_locus
))
2422 vtab
->attr
.target
= 1;
2423 vtab
->attr
.save
= SAVE_IMPLICIT
;
2424 vtab
->attr
.vtab
= 1;
2425 vtab
->attr
.access
= ACCESS_PUBLIC
;
2426 gfc_set_sym_referenced (vtab
);
2428 name
= xasprintf ("__vtype_%s", tname
);
2430 gfc_find_symbol (name
, ns
, 0, &vtype
);
2434 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2437 /* Is this a derived type with recursive allocatable
2439 c
= (derived
->attr
.unlimited_polymorphic
2440 || derived
->attr
.abstract
) ?
2441 NULL
: derived
->components
;
2442 for (; c
; c
= c
->next
)
2443 if (c
->ts
.type
== BT_DERIVED
2444 && c
->ts
.u
.derived
== derived
)
2450 gfc_get_symbol (name
, ns
, &vtype
);
2451 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2452 &gfc_current_locus
))
2454 vtype
->attr
.access
= ACCESS_PUBLIC
;
2455 vtype
->attr
.vtype
= 1;
2456 gfc_set_sym_referenced (vtype
);
2458 /* Add component '_hash'. */
2459 if (!gfc_add_component (vtype
, "_hash", &c
))
2461 c
->ts
.type
= BT_INTEGER
;
2463 c
->attr
.access
= ACCESS_PRIVATE
;
2464 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2465 NULL
, derived
->hash_value
);
2467 /* Add component '_size'. */
2468 if (!gfc_add_component (vtype
, "_size", &c
))
2470 c
->ts
.type
= BT_INTEGER
;
2471 c
->ts
.kind
= gfc_size_kind
;
2472 c
->attr
.access
= ACCESS_PRIVATE
;
2473 /* Remember the derived type in ts.u.derived,
2474 so that the correct initializer can be set later on
2475 (in gfc_conv_structure). */
2476 c
->ts
.u
.derived
= derived
;
2477 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2480 /* Add component _extends. */
2481 if (!gfc_add_component (vtype
, "_extends", &c
))
2483 c
->attr
.pointer
= 1;
2484 c
->attr
.access
= ACCESS_PRIVATE
;
2485 if (!derived
->attr
.unlimited_polymorphic
)
2486 parent
= gfc_get_derived_super_type (derived
);
2492 parent_vtab
= gfc_find_derived_vtab (parent
);
2493 c
->ts
.type
= BT_DERIVED
;
2494 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2495 c
->initializer
= gfc_get_expr ();
2496 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2497 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2498 0, &c
->initializer
->symtree
);
2502 c
->ts
.type
= BT_DERIVED
;
2503 c
->ts
.u
.derived
= vtype
;
2504 c
->initializer
= gfc_get_null_expr (NULL
);
2507 if (!derived
->attr
.unlimited_polymorphic
2508 && derived
->components
== NULL
2509 && !derived
->attr
.zero_comp
)
2511 /* At this point an error must have occurred.
2512 Prevent further errors on the vtype components. */
2517 /* Add component _def_init. */
2518 if (!gfc_add_component (vtype
, "_def_init", &c
))
2520 c
->attr
.pointer
= 1;
2521 c
->attr
.artificial
= 1;
2522 c
->attr
.access
= ACCESS_PRIVATE
;
2523 c
->ts
.type
= BT_DERIVED
;
2524 c
->ts
.u
.derived
= derived
;
2525 if (derived
->attr
.unlimited_polymorphic
2526 || derived
->attr
.abstract
)
2527 c
->initializer
= gfc_get_null_expr (NULL
);
2530 /* Construct default initialization variable. */
2532 name
= xasprintf ("__def_init_%s", tname
);
2533 gfc_get_symbol (name
, ns
, &def_init
);
2534 def_init
->attr
.target
= 1;
2535 def_init
->attr
.artificial
= 1;
2536 def_init
->attr
.save
= SAVE_IMPLICIT
;
2537 def_init
->attr
.access
= ACCESS_PUBLIC
;
2538 def_init
->attr
.flavor
= FL_VARIABLE
;
2539 gfc_set_sym_referenced (def_init
);
2540 def_init
->ts
.type
= BT_DERIVED
;
2541 def_init
->ts
.u
.derived
= derived
;
2542 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2544 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2547 /* Add component _copy. */
2548 if (!gfc_add_component (vtype
, "_copy", &c
))
2550 c
->attr
.proc_pointer
= 1;
2551 c
->attr
.access
= ACCESS_PRIVATE
;
2552 c
->tb
= XCNEW (gfc_typebound_proc
);
2554 if (derived
->attr
.unlimited_polymorphic
2555 || derived
->attr
.abstract
)
2556 c
->initializer
= gfc_get_null_expr (NULL
);
2559 /* Set up namespace. */
2560 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2561 sub_ns
->sibling
= ns
->contained
;
2562 ns
->contained
= sub_ns
;
2563 sub_ns
->resolved
= 1;
2564 /* Set up procedure symbol. */
2566 name
= xasprintf ("__copy_%s", tname
);
2567 gfc_get_symbol (name
, sub_ns
, ©
);
2568 sub_ns
->proc_name
= copy
;
2569 copy
->attr
.flavor
= FL_PROCEDURE
;
2570 copy
->attr
.subroutine
= 1;
2571 copy
->attr
.pure
= 1;
2572 copy
->attr
.artificial
= 1;
2573 copy
->attr
.if_source
= IFSRC_DECL
;
2574 /* This is elemental so that arrays are automatically
2575 treated correctly by the scalarizer. */
2576 copy
->attr
.elemental
= 1;
2577 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2578 copy
->module
= ns
->proc_name
->name
;
2579 gfc_set_sym_referenced (copy
);
2580 /* Set up formal arguments. */
2581 gfc_get_symbol ("src", sub_ns
, &src
);
2582 src
->ts
.type
= BT_DERIVED
;
2583 src
->ts
.u
.derived
= derived
;
2584 src
->attr
.flavor
= FL_VARIABLE
;
2585 src
->attr
.dummy
= 1;
2586 src
->attr
.artificial
= 1;
2587 src
->attr
.intent
= INTENT_IN
;
2588 gfc_set_sym_referenced (src
);
2589 copy
->formal
= gfc_get_formal_arglist ();
2590 copy
->formal
->sym
= src
;
2591 gfc_get_symbol ("dst", sub_ns
, &dst
);
2592 dst
->ts
.type
= BT_DERIVED
;
2593 dst
->ts
.u
.derived
= derived
;
2594 dst
->attr
.flavor
= FL_VARIABLE
;
2595 dst
->attr
.dummy
= 1;
2596 dst
->attr
.artificial
= 1;
2597 dst
->attr
.intent
= INTENT_INOUT
;
2598 gfc_set_sym_referenced (dst
);
2599 copy
->formal
->next
= gfc_get_formal_arglist ();
2600 copy
->formal
->next
->sym
= dst
;
2602 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2603 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2604 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2605 /* Set initializer. */
2606 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2607 c
->ts
.interface
= copy
;
2610 /* Add component _final, which contains a procedure pointer to
2611 a wrapper which handles both the freeing of allocatable
2612 components and the calls to finalization subroutines.
2613 Note: The actual wrapper function can only be generated
2614 at resolution time. */
2615 if (!gfc_add_component (vtype
, "_final", &c
))
2617 c
->attr
.proc_pointer
= 1;
2618 c
->attr
.access
= ACCESS_PRIVATE
;
2619 c
->attr
.artificial
= 1;
2620 c
->tb
= XCNEW (gfc_typebound_proc
);
2622 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2624 /* Add component _deallocate. */
2625 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2627 c
->attr
.proc_pointer
= 1;
2628 c
->attr
.access
= ACCESS_PRIVATE
;
2629 c
->tb
= XCNEW (gfc_typebound_proc
);
2631 if (derived
->attr
.unlimited_polymorphic
2632 || derived
->attr
.abstract
2634 c
->initializer
= gfc_get_null_expr (NULL
);
2637 /* Set up namespace. */
2638 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2640 sub_ns
->sibling
= ns
->contained
;
2641 ns
->contained
= sub_ns
;
2642 sub_ns
->resolved
= 1;
2643 /* Set up procedure symbol. */
2645 name
= xasprintf ("__deallocate_%s", tname
);
2646 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2647 sub_ns
->proc_name
= dealloc
;
2648 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2649 dealloc
->attr
.subroutine
= 1;
2650 dealloc
->attr
.pure
= 1;
2651 dealloc
->attr
.artificial
= 1;
2652 dealloc
->attr
.if_source
= IFSRC_DECL
;
2654 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2655 dealloc
->module
= ns
->proc_name
->name
;
2656 gfc_set_sym_referenced (dealloc
);
2657 /* Set up formal argument. */
2658 gfc_get_symbol ("arg", sub_ns
, &arg
);
2659 arg
->ts
.type
= BT_DERIVED
;
2660 arg
->ts
.u
.derived
= derived
;
2661 arg
->attr
.flavor
= FL_VARIABLE
;
2662 arg
->attr
.dummy
= 1;
2663 arg
->attr
.artificial
= 1;
2664 arg
->attr
.intent
= INTENT_INOUT
;
2665 arg
->attr
.dimension
= 1;
2666 arg
->attr
.allocatable
= 1;
2667 arg
->as
= gfc_get_array_spec();
2668 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2670 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2672 gfc_set_sym_referenced (arg
);
2673 dealloc
->formal
= gfc_get_formal_arglist ();
2674 dealloc
->formal
->sym
= arg
;
2676 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2677 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2678 sub_ns
->code
->ext
.alloc
.list
->expr
2679 = gfc_lval_expr_from_sym (arg
);
2680 /* Set initializer. */
2681 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2682 c
->ts
.interface
= dealloc
;
2685 /* Add procedure pointers for type-bound procedures. */
2686 if (!derived
->attr
.unlimited_polymorphic
)
2687 add_procs_to_declared_vtab (derived
, vtype
);
2691 vtab
->ts
.u
.derived
= vtype
;
2692 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2700 /* It is unexpected to have some symbols added at resolution or code
2701 generation time. We commit the changes in order to keep a clean state. */
2704 gfc_commit_symbol (vtab
);
2706 gfc_commit_symbol (vtype
);
2708 gfc_commit_symbol (def_init
);
2710 gfc_commit_symbol (copy
);
2712 gfc_commit_symbol (src
);
2714 gfc_commit_symbol (dst
);
2716 gfc_commit_symbol (dealloc
);
2718 gfc_commit_symbol (arg
);
2721 gfc_undo_symbols ();
2727 /* Check if a derived type is finalizable. That is the case if it
2728 (1) has a FINAL subroutine or
2729 (2) has a nonpointer nonallocatable component of finalizable type.
2730 If it is finalizable, return an expression containing the
2731 finalization wrapper. */
2734 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2739 /* (1) Check for FINAL subroutines. */
2740 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2743 /* (2) Check for components of finalizable type. */
2744 for (c
= derived
->components
; c
; c
= c
->next
)
2745 if (c
->ts
.type
== BT_DERIVED
2746 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2747 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2753 /* Make sure vtab is generated. */
2754 vtab
= gfc_find_derived_vtab (derived
);
2757 /* Return finalizer expression. */
2758 gfc_component
*final
;
2759 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2760 gcc_assert (strcmp (final
->name
, "_final") == 0);
2761 gcc_assert (final
->initializer
2762 && final
->initializer
->expr_type
!= EXPR_NULL
);
2763 *final_expr
= final
->initializer
;
2770 gfc_may_be_finalized (gfc_typespec ts
)
2772 return (ts
.type
== BT_CLASS
|| (ts
.type
== BT_DERIVED
2773 && ts
.u
.derived
&& gfc_is_finalizable (ts
.u
.derived
, NULL
)));
2777 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2778 needed to support unlimited polymorphism. */
2781 find_intrinsic_vtab (gfc_typespec
*ts
)
2784 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2785 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2787 /* Find the top-level namespace. */
2788 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2794 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2797 /* Encode all types as TYPENAME_KIND_ including especially character
2798 arrays, whose length is now consistently stored in the _len component
2799 of the class-variable. */
2800 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2801 name
= xasprintf ("__vtab_%s", tname
);
2803 /* Look for the vtab symbol in the top-level namespace only. */
2804 gfc_find_symbol (name
, ns
, 0, &vtab
);
2808 gfc_get_symbol (name
, ns
, &vtab
);
2809 vtab
->ts
.type
= BT_DERIVED
;
2810 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2811 &gfc_current_locus
))
2813 vtab
->attr
.target
= 1;
2814 vtab
->attr
.save
= SAVE_IMPLICIT
;
2815 vtab
->attr
.vtab
= 1;
2816 vtab
->attr
.access
= ACCESS_PUBLIC
;
2817 gfc_set_sym_referenced (vtab
);
2819 name
= xasprintf ("__vtype_%s", tname
);
2821 gfc_find_symbol (name
, ns
, 0, &vtype
);
2826 gfc_namespace
*sub_ns
;
2827 gfc_namespace
*contained
;
2831 gfc_get_symbol (name
, ns
, &vtype
);
2832 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2833 &gfc_current_locus
))
2835 vtype
->attr
.access
= ACCESS_PUBLIC
;
2836 vtype
->attr
.vtype
= 1;
2837 gfc_set_sym_referenced (vtype
);
2839 /* Add component '_hash'. */
2840 if (!gfc_add_component (vtype
, "_hash", &c
))
2842 c
->ts
.type
= BT_INTEGER
;
2844 c
->attr
.access
= ACCESS_PRIVATE
;
2845 hash
= gfc_intrinsic_hash_value (ts
);
2846 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2849 /* Add component '_size'. */
2850 if (!gfc_add_component (vtype
, "_size", &c
))
2852 c
->ts
.type
= BT_INTEGER
;
2853 c
->ts
.kind
= gfc_size_kind
;
2854 c
->attr
.access
= ACCESS_PRIVATE
;
2856 /* Build a minimal expression to make use of
2857 target-memory.cc/gfc_element_size for 'size'. Special handling
2858 for character arrays, that are not constant sized: to support
2859 len (str) * kind, only the kind information is stored in the
2861 e
= gfc_get_expr ();
2863 e
->expr_type
= EXPR_VARIABLE
;
2864 if (ts
->type
== BT_CHARACTER
)
2867 gfc_element_size (e
, &e_size
);
2868 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2873 /* Add component _extends. */
2874 if (!gfc_add_component (vtype
, "_extends", &c
))
2876 c
->attr
.pointer
= 1;
2877 c
->attr
.access
= ACCESS_PRIVATE
;
2878 c
->ts
.type
= BT_VOID
;
2879 c
->initializer
= gfc_get_null_expr (NULL
);
2881 /* Add component _def_init. */
2882 if (!gfc_add_component (vtype
, "_def_init", &c
))
2884 c
->attr
.pointer
= 1;
2885 c
->attr
.access
= ACCESS_PRIVATE
;
2886 c
->ts
.type
= BT_VOID
;
2887 c
->initializer
= gfc_get_null_expr (NULL
);
2889 /* Add component _copy. */
2890 if (!gfc_add_component (vtype
, "_copy", &c
))
2892 c
->attr
.proc_pointer
= 1;
2893 c
->attr
.access
= ACCESS_PRIVATE
;
2894 c
->tb
= XCNEW (gfc_typebound_proc
);
2898 if (ts
->type
!= BT_CHARACTER
)
2899 name
= xasprintf ("__copy_%s", tname
);
2902 /* __copy is always the same for characters.
2903 Check to see if copy function already exists. */
2904 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2905 contained
= ns
->contained
;
2906 for (; contained
; contained
= contained
->sibling
)
2907 if (contained
->proc_name
2908 && strcmp (name
, contained
->proc_name
->name
) == 0)
2910 copy
= contained
->proc_name
;
2915 /* Set up namespace. */
2916 sub_ns
= gfc_get_namespace (ns
, 0);
2917 sub_ns
->sibling
= ns
->contained
;
2918 ns
->contained
= sub_ns
;
2919 sub_ns
->resolved
= 1;
2920 /* Set up procedure symbol. */
2921 gfc_get_symbol (name
, sub_ns
, ©
);
2922 sub_ns
->proc_name
= copy
;
2923 copy
->attr
.flavor
= FL_PROCEDURE
;
2924 copy
->attr
.subroutine
= 1;
2925 copy
->attr
.pure
= 1;
2926 copy
->attr
.if_source
= IFSRC_DECL
;
2927 /* This is elemental so that arrays are automatically
2928 treated correctly by the scalarizer. */
2929 copy
->attr
.elemental
= 1;
2930 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2931 copy
->module
= ns
->proc_name
->name
;
2932 gfc_set_sym_referenced (copy
);
2933 /* Set up formal arguments. */
2934 gfc_get_symbol ("src", sub_ns
, &src
);
2935 src
->ts
.type
= ts
->type
;
2936 src
->ts
.kind
= ts
->kind
;
2937 src
->attr
.flavor
= FL_VARIABLE
;
2938 src
->attr
.dummy
= 1;
2939 src
->attr
.intent
= INTENT_IN
;
2940 gfc_set_sym_referenced (src
);
2941 copy
->formal
= gfc_get_formal_arglist ();
2942 copy
->formal
->sym
= src
;
2943 gfc_get_symbol ("dst", sub_ns
, &dst
);
2944 dst
->ts
.type
= ts
->type
;
2945 dst
->ts
.kind
= ts
->kind
;
2946 dst
->attr
.flavor
= FL_VARIABLE
;
2947 dst
->attr
.dummy
= 1;
2948 dst
->attr
.intent
= INTENT_INOUT
;
2949 gfc_set_sym_referenced (dst
);
2950 copy
->formal
->next
= gfc_get_formal_arglist ();
2951 copy
->formal
->next
->sym
= dst
;
2953 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2954 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2955 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2957 /* Set initializer. */
2958 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2959 c
->ts
.interface
= copy
;
2961 /* Add component _final. */
2962 if (!gfc_add_component (vtype
, "_final", &c
))
2964 c
->attr
.proc_pointer
= 1;
2965 c
->attr
.access
= ACCESS_PRIVATE
;
2966 c
->attr
.artificial
= 1;
2967 c
->tb
= XCNEW (gfc_typebound_proc
);
2969 c
->initializer
= gfc_get_null_expr (NULL
);
2971 vtab
->ts
.u
.derived
= vtype
;
2972 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2980 /* It is unexpected to have some symbols added at resolution or code
2981 generation time. We commit the changes in order to keep a clean state. */
2984 gfc_commit_symbol (vtab
);
2986 gfc_commit_symbol (vtype
);
2988 gfc_commit_symbol (copy
);
2990 gfc_commit_symbol (src
);
2992 gfc_commit_symbol (dst
);
2995 gfc_undo_symbols ();
3001 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
3004 gfc_find_vtab (gfc_typespec
*ts
)
3011 return gfc_find_derived_vtab (ts
->u
.derived
);
3013 if (ts
->u
.derived
->attr
.is_class
3014 && ts
->u
.derived
->components
3015 && ts
->u
.derived
->components
->ts
.u
.derived
)
3016 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
3020 return find_intrinsic_vtab (ts
);
3025 /* General worker function to find either a type-bound procedure or a
3026 type-bound user operator. */
3029 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
3030 const char* name
, bool noaccess
, bool uop
,
3036 /* Set default to failure. */
3040 if (derived
->f2k_derived
)
3041 /* Set correct symbol-root. */
3042 root
= (uop
? derived
->f2k_derived
->tb_uop_root
3043 : derived
->f2k_derived
->tb_sym_root
);
3047 /* Try to find it in the current type's namespace. */
3048 res
= gfc_find_symtree (root
, name
);
3049 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
3055 if (!noaccess
&& derived
->attr
.use_assoc
3056 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
3059 gfc_error ("%qs of %qs is PRIVATE at %L",
3060 name
, derived
->name
, where
);
3068 /* Otherwise, recurse on parent type if derived is an extension. */
3069 if (derived
->attr
.extension
)
3071 gfc_symbol
* super_type
;
3072 super_type
= gfc_get_derived_super_type (derived
);
3073 gcc_assert (super_type
);
3075 return find_typebound_proc_uop (super_type
, t
, name
,
3076 noaccess
, uop
, where
);
3079 /* Nothing found. */
3084 /* Find a type-bound procedure or user operator by name for a derived-type
3085 (looking recursively through the super-types). */
3088 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
3089 const char* name
, bool noaccess
, locus
* where
)
3091 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
3095 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
3096 const char* name
, bool noaccess
, locus
* where
)
3098 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
3102 /* Find a type-bound intrinsic operator looking recursively through the
3103 super-type hierarchy. */
3106 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
3107 gfc_intrinsic_op op
, bool noaccess
,
3110 gfc_typebound_proc
* res
;
3112 /* Set default to failure. */
3116 /* Try to find it in the current type's namespace. */
3117 if (derived
->f2k_derived
)
3118 res
= derived
->f2k_derived
->tb_op
[op
];
3123 if (res
&& !res
->error
)
3129 if (!noaccess
&& derived
->attr
.use_assoc
3130 && res
->access
== ACCESS_PRIVATE
)
3133 gfc_error ("%qs of %qs is PRIVATE at %L",
3134 gfc_op2string (op
), derived
->name
, where
);
3142 /* Otherwise, recurse on parent type if derived is an extension. */
3143 if (derived
->attr
.extension
)
3145 gfc_symbol
* super_type
;
3146 super_type
= gfc_get_derived_super_type (derived
);
3147 gcc_assert (super_type
);
3149 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3153 /* Nothing found. */
3158 /* Get a typebound-procedure symtree or create and insert it if not yet
3159 present. This is like a very simplified version of gfc_get_sym_tree for
3160 tbp-symtrees rather than regular ones. */
3163 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3165 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3166 return result
? result
: gfc_new_symtree (root
, name
);