1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2023 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 /* Class container has already been built with same name. */
652 && ts
->u
.derived
->components
->attr
.dimension
>= attr
->dimension
653 && ts
->u
.derived
->components
->attr
.codimension
>= attr
->codimension
654 && ts
->u
.derived
->components
->attr
.class_pointer
>= attr
->pointer
655 && ts
->u
.derived
->components
->attr
.allocatable
>= attr
->allocatable
)
659 attr
->dimension
|= ts
->u
.derived
->components
->attr
.dimension
;
660 attr
->codimension
|= ts
->u
.derived
->components
->attr
.codimension
;
661 attr
->pointer
|= ts
->u
.derived
->components
->attr
.class_pointer
;
662 attr
->allocatable
|= ts
->u
.derived
->components
->attr
.allocatable
;
663 ts
= &ts
->u
.derived
->components
->ts
;
666 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
667 || attr
->select_type_temporary
|| attr
->associate_var
;
670 /* We cannot build the class container yet. */
673 /* Determine the name of the encapsulating type. */
674 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
679 get_unique_hashed_string (tname
, ts
->u
.derived
);
680 if ((*as
) && attr
->allocatable
)
681 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
682 else if ((*as
) && attr
->pointer
)
683 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
685 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
686 else if (attr
->pointer
)
687 name
= xasprintf ("__class_%s_p", tname
);
688 else if (attr
->allocatable
)
689 name
= xasprintf ("__class_%s_a", tname
);
691 name
= xasprintf ("__class_%s_t", tname
);
693 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
695 /* Find the top-level namespace. */
696 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
701 ns
= ts
->u
.derived
->ns
;
703 /* Although this might seem to be counterintuitive, we can build separate
704 class types with different array specs because the TKR interface checks
705 work on the declared type. All array type other than deferred shape or
706 assumed rank are added to the function namespace to ensure that they
707 are properly distinguished. */
708 if (attr
->dummy
&& !attr
->codimension
&& (*as
)
709 && !((*as
)->type
== AS_DEFERRED
|| (*as
)->type
== AS_ASSUMED_RANK
))
713 gfc_find_symbol (name
, ns
, 0, &fclass
);
714 /* If a local class type with this name already exists, update the
715 name with an index. */
719 sname
= xasprintf ("%s_%d", name
, ++ctr
);
725 gfc_find_symbol (name
, ns
, 0, &fclass
);
730 /* If not there, create a new symbol. */
731 fclass
= gfc_new_symbol (name
, ns
);
732 st
= gfc_new_symtree (&ns
->sym_root
, name
);
734 gfc_set_sym_referenced (fclass
);
736 fclass
->ts
.type
= BT_UNKNOWN
;
737 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
738 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
739 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
740 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
744 /* Add component '_data'. */
745 if (!gfc_add_component (fclass
, "_data", &c
))
748 c
->ts
.type
= BT_DERIVED
;
749 c
->attr
.access
= ACCESS_PRIVATE
;
750 c
->ts
.u
.derived
= ts
->u
.derived
;
751 c
->attr
.class_pointer
= attr
->pointer
;
752 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
753 || attr
->select_type_temporary
;
754 c
->attr
.allocatable
= attr
->allocatable
;
755 c
->attr
.dimension
= attr
->dimension
;
756 c
->attr
.codimension
= attr
->codimension
;
757 c
->attr
.abstract
= fclass
->attr
.abstract
;
759 c
->initializer
= NULL
;
761 /* Add component '_vptr'. */
762 if (!gfc_add_component (fclass
, "_vptr", &c
))
764 c
->ts
.type
= BT_DERIVED
;
765 c
->attr
.access
= ACCESS_PRIVATE
;
768 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
770 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
772 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
774 /* Add component '_len'. Only unlimited polymorphic pointers may
775 have a string assigned to them, i.e., only those need the _len
777 if (!gfc_add_component (fclass
, "_len", &c
))
779 c
->ts
.type
= BT_INTEGER
;
780 c
->ts
.kind
= gfc_charlen_int_kind
;
781 c
->attr
.access
= ACCESS_PRIVATE
;
782 c
->attr
.artificial
= 1;
785 /* Build vtab later. */
786 c
->ts
.u
.derived
= NULL
;
789 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
791 /* Since the extension field is 8 bit wide, we can only have
792 up to 255 extension levels. */
793 if (ts
->u
.derived
->attr
.extension
== 255)
795 gfc_error ("Maximum extension level reached with type %qs at %L",
796 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
800 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
801 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
802 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
805 fclass
->attr
.is_class
= 1;
806 orig_ts
->u
.derived
= fclass
;
807 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
814 /* Add a procedure pointer component to the vtype
815 to represent a specific type-bound procedure. */
818 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
822 if (tb
->non_overridable
&& !tb
->overridden
)
825 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
829 /* Add procedure component. */
830 if (!gfc_add_component (vtype
, name
, &c
))
834 c
->tb
= XCNEW (gfc_typebound_proc
);
837 c
->attr
.procedure
= 1;
838 c
->attr
.proc_pointer
= 1;
839 c
->attr
.flavor
= FL_PROCEDURE
;
840 c
->attr
.access
= ACCESS_PRIVATE
;
841 c
->attr
.external
= 1;
843 c
->attr
.if_source
= IFSRC_IFBODY
;
845 else if (c
->attr
.proc_pointer
&& c
->tb
)
853 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
854 c
->ts
.interface
= ifc
;
856 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
857 c
->attr
.pure
= ifc
->attr
.pure
;
862 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
865 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
871 add_procs_to_declared_vtab1 (st
->left
, vtype
);
874 add_procs_to_declared_vtab1 (st
->right
, vtype
);
876 if (st
->n
.tb
&& !st
->n
.tb
->error
877 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
878 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
882 /* Copy procedure pointers components from the parent type. */
885 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
890 vtab
= gfc_find_derived_vtab (declared
);
892 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
894 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
897 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
902 /* Returns true if any of its nonpointer nonallocatable components or
903 their nonpointer nonallocatable subcomponents has a finalization
907 has_finalizer_component (gfc_symbol
*derived
)
911 for (c
= derived
->components
; c
; c
= c
->next
)
912 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
913 && c
->attr
.flavor
!= FL_PROCEDURE
)
915 if (c
->ts
.u
.derived
->f2k_derived
916 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
919 /* Stop infinite recursion through this function by inhibiting
920 calls when the derived type and that of the component are
922 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
923 && has_finalizer_component (c
->ts
.u
.derived
))
931 comp_is_finalizable (gfc_component
*comp
)
933 if (comp
->attr
.proc_pointer
)
935 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
937 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
938 && (comp
->ts
.u
.derived
->attr
.alloc_comp
939 || has_finalizer_component (comp
->ts
.u
.derived
)
940 || (comp
->ts
.u
.derived
->f2k_derived
941 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
943 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
944 && CLASS_DATA (comp
)->attr
.allocatable
)
951 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
952 neither allocatable nor a pointer but has a finalizer, call it. If it
953 is a nonpointer component with allocatable components or has finalizers, walk
954 them. Either of them is required; other nonallocatables and pointers aren't
956 Note: If the component is allocatable, the DEALLOCATE handling takes care
957 of calling the appropriate finalizers, coarray deregistering, and
958 deallocation of allocatable subcomponents. */
961 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
962 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
963 gfc_namespace
*sub_ns
)
967 gfc_was_finalized
*f
;
969 if (!comp_is_finalizable (comp
))
972 /* If this expression with this component has been finalized
973 already in this namespace, there is nothing to do. */
974 for (f
= sub_ns
->was_finalized
; f
; f
= f
->next
)
976 if (f
->e
== expr
&& f
->c
== comp
)
980 e
= gfc_copy_expr (expr
);
982 e
->ref
= ref
= gfc_get_ref ();
985 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
987 ref
->next
= gfc_get_ref ();
990 ref
->type
= REF_COMPONENT
;
991 ref
->u
.c
.sym
= derived
;
992 ref
->u
.c
.component
= comp
;
995 if (comp
->attr
.dimension
|| comp
->attr
.codimension
996 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
997 && (CLASS_DATA (comp
)->attr
.dimension
998 || CLASS_DATA (comp
)->attr
.codimension
)))
1000 ref
->next
= gfc_get_ref ();
1001 ref
->next
->type
= REF_ARRAY
;
1002 ref
->next
->u
.ar
.dimen
= 0;
1003 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
1005 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
1006 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
1009 /* Call DEALLOCATE (comp, stat=ignore). */
1010 if (comp
->attr
.allocatable
1011 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1012 && CLASS_DATA (comp
)->attr
.allocatable
))
1014 gfc_code
*dealloc
, *block
= NULL
;
1016 /* Add IF (fini_coarray). */
1017 if (comp
->attr
.codimension
1018 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1019 && CLASS_DATA (comp
)->attr
.codimension
))
1021 block
= gfc_get_code (EXEC_IF
);
1024 (*code
)->next
= block
;
1025 (*code
) = (*code
)->next
;
1030 block
->block
= gfc_get_code (EXEC_IF
);
1031 block
= block
->block
;
1032 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
1035 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
1037 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
1038 dealloc
->ext
.alloc
.list
->expr
= e
;
1039 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
1041 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
1042 cond
->block
= gfc_get_code (EXEC_IF
);
1043 cond
->block
->expr1
= gfc_get_expr ();
1044 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
1045 cond
->block
->expr1
->where
= gfc_current_locus
;
1046 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
1047 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1048 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1049 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
1050 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
1051 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
1052 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1053 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
1054 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
1055 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
1056 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1057 cond
->block
->next
= dealloc
;
1063 (*code
)->next
= cond
;
1064 (*code
) = (*code
)->next
;
1070 else if (comp
->ts
.type
== BT_DERIVED
1071 && comp
->ts
.u
.derived
->f2k_derived
1072 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1074 /* Call FINAL_WRAPPER (comp); */
1075 gfc_code
*final_wrap
;
1076 gfc_symbol
*vtab
, *byte_stride
;
1077 gfc_expr
*scalar
, *size_expr
, *fini_coarray_expr
;
1080 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1081 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1082 if (strcmp (c
->name
, "_final") == 0)
1087 /* Set scalar argument for storage_size. */
1088 gfc_get_symbol ("comp_byte_stride", sub_ns
, &byte_stride
);
1089 byte_stride
->ts
= e
->ts
;
1090 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1091 byte_stride
->attr
.value
= 1;
1092 byte_stride
->attr
.artificial
= 1;
1093 gfc_set_sym_referenced (byte_stride
);
1094 gfc_commit_symbol (byte_stride
);
1095 scalar
= gfc_lval_expr_from_sym (byte_stride
);
1097 final_wrap
= gfc_get_code (EXEC_CALL
);
1098 final_wrap
->symtree
= c
->initializer
->symtree
;
1099 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1100 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1101 final_wrap
->ext
.actual
->expr
= e
;
1103 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1104 size_expr
= gfc_get_expr ();
1105 size_expr
->where
= gfc_current_locus
;
1106 size_expr
->expr_type
= EXPR_OP
;
1107 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1109 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1110 size_expr
->value
.op
.op1
1111 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1112 "storage_size", gfc_current_locus
, 2,
1114 gfc_get_int_expr (gfc_index_integer_kind
,
1117 /* NUMERIC_STORAGE_SIZE. */
1118 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1119 gfc_character_storage_size
);
1120 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1121 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1123 /* Which provides the argument 'byte_stride'..... */
1124 final_wrap
->ext
.actual
->next
= gfc_get_actual_arglist ();
1125 final_wrap
->ext
.actual
->next
->expr
= size_expr
;
1127 /* ...and last of all the 'fini_coarray' argument. */
1128 fini_coarray_expr
= gfc_lval_expr_from_sym (fini_coarray
);
1129 final_wrap
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1130 final_wrap
->ext
.actual
->next
->next
->expr
= fini_coarray_expr
;
1136 (*code
)->next
= final_wrap
;
1137 (*code
) = (*code
)->next
;
1140 (*code
) = final_wrap
;
1146 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1147 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1152 /* Record that this was finalized already in this namespace. */
1153 f
= sub_ns
->was_finalized
;
1154 sub_ns
->was_finalized
= XCNEW (gfc_was_finalized
);
1155 sub_ns
->was_finalized
->e
= expr
;
1156 sub_ns
->was_finalized
->c
= comp
;
1157 sub_ns
->was_finalized
->next
= f
;
1161 /* Generate code equivalent to
1162 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1163 + offset, c_ptr), ptr). */
1166 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1167 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1170 gfc_expr
*expr
, *expr2
;
1172 /* C_F_POINTER(). */
1173 block
= gfc_get_code (EXEC_CALL
);
1174 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1175 block
->resolved_sym
= block
->symtree
->n
.sym
;
1176 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1177 block
->resolved_sym
->attr
.intrinsic
= 1;
1178 block
->resolved_sym
->attr
.subroutine
= 1;
1179 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1180 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1181 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1182 gfc_commit_symbol (block
->resolved_sym
);
1184 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1185 block
->ext
.actual
= gfc_get_actual_arglist ();
1186 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1187 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1189 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1191 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1193 /* TRANSFER's first argument: C_LOC (array). */
1194 expr
= gfc_get_expr ();
1195 expr
->expr_type
= EXPR_FUNCTION
;
1196 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1197 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1198 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1199 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1200 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1201 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1202 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1203 expr
->value
.function
.actual
->expr
1204 = gfc_lval_expr_from_sym (array
);
1205 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1206 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1207 expr
->ts
.type
= BT_INTEGER
;
1208 expr
->ts
.kind
= gfc_index_integer_kind
;
1209 expr
->where
= gfc_current_locus
;
1212 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1213 gfc_current_locus
, 3, expr
,
1214 gfc_get_int_expr (gfc_index_integer_kind
,
1216 expr2
->ts
.type
= BT_INTEGER
;
1217 expr2
->ts
.kind
= gfc_index_integer_kind
;
1219 /* <array addr> + <offset>. */
1220 block
->ext
.actual
->expr
= gfc_get_expr ();
1221 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1222 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1223 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1224 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1225 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1226 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1228 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1229 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1230 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1231 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1237 /* Calculates the offset to the (idx+1)th element of an array, taking the
1238 stride into account. It generates the code:
1241 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1243 offset = offset * byte_stride. */
1246 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1247 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1248 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1249 gfc_code
*block
, gfc_namespace
*sub_ns
)
1252 gfc_expr
*expr
, *expr2
;
1255 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1256 block
= block
->next
;
1257 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1258 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1261 iter
= gfc_get_iterator ();
1262 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1263 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1264 iter
->end
= gfc_copy_expr (rank
);
1265 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1266 block
->next
= gfc_get_code (EXEC_DO
);
1267 block
= block
->next
;
1268 block
->ext
.iterator
= iter
;
1269 block
->block
= gfc_get_code (EXEC_DO
);
1271 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1274 /* mod (idx, sizes(idx2)). */
1275 expr
= gfc_lval_expr_from_sym (sizes
);
1276 expr
->ref
= gfc_get_ref ();
1277 expr
->ref
->type
= REF_ARRAY
;
1278 expr
->ref
->u
.ar
.as
= sizes
->as
;
1279 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1280 expr
->ref
->u
.ar
.dimen
= 1;
1281 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1282 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1283 expr
->where
= sizes
->declared_at
;
1285 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1286 gfc_current_locus
, 2,
1287 gfc_lval_expr_from_sym (idx
), expr
);
1290 /* (...) / sizes(idx2-1). */
1291 expr2
= gfc_get_expr ();
1292 expr2
->expr_type
= EXPR_OP
;
1293 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1294 expr2
->value
.op
.op1
= expr
;
1295 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1296 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1297 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1298 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1299 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1300 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1301 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1302 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1303 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1304 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1305 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1306 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1307 = gfc_lval_expr_from_sym (idx2
);
1308 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1309 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1310 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1311 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1312 expr2
->ts
= idx
->ts
;
1313 expr2
->where
= gfc_current_locus
;
1315 /* ... * strides(idx2). */
1316 expr
= gfc_get_expr ();
1317 expr
->expr_type
= EXPR_OP
;
1318 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1319 expr
->value
.op
.op1
= expr2
;
1320 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1321 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1322 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1323 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1324 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1325 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1326 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1327 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1329 expr
->where
= gfc_current_locus
;
1331 /* offset = offset + ... */
1332 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1333 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1334 block
->block
->next
->expr2
= gfc_get_expr ();
1335 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1336 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1337 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1338 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1339 block
->block
->next
->expr2
->ts
= idx
->ts
;
1340 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1342 /* After the loop: offset = offset * byte_stride. */
1343 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1344 block
= block
->next
;
1345 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1346 block
->expr2
= gfc_get_expr ();
1347 block
->expr2
->expr_type
= EXPR_OP
;
1348 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1349 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1350 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1351 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1352 block
->expr2
->where
= gfc_current_locus
;
1357 /* Insert code of the following form:
1360 integer(c_intptr_t) :: i
1362 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1363 && (is_contiguous || !final_rank3->attr.contiguous
1364 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1365 || 0 == STORAGE_SIZE (array)) then
1366 call final_rank3 (array)
1369 integer(c_intptr_t) :: offset, j
1370 type(t) :: tmp(shape (array))
1372 do i = 0, size (array)-1
1373 offset = obtain_offset(i, strides, sizes, byte_stride)
1374 addr = transfer (c_loc (array), addr) + offset
1375 call c_f_pointer (transfer (addr, cptr), ptr)
1377 addr = transfer (c_loc (tmp), addr)
1378 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1379 call c_f_pointer (transfer (addr, cptr), ptr2)
1382 call final_rank3 (tmp)
1388 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1389 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1390 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1392 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1393 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1394 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1395 gfc_namespace
*sub_ns
)
1397 gfc_symbol
*tmp_array
, *ptr2
;
1398 gfc_expr
*size_expr
, *offset2
, *expr
;
1404 block
->next
= gfc_get_code (EXEC_IF
);
1405 block
= block
->next
;
1407 block
->block
= gfc_get_code (EXEC_IF
);
1408 block
= block
->block
;
1410 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1411 size_expr
= gfc_get_expr ();
1412 size_expr
->where
= gfc_current_locus
;
1413 size_expr
->expr_type
= EXPR_OP
;
1414 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1416 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1417 size_expr
->value
.op
.op1
1418 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1419 "storage_size", gfc_current_locus
, 2,
1420 gfc_lval_expr_from_sym (array
),
1421 gfc_get_int_expr (gfc_index_integer_kind
,
1424 /* NUMERIC_STORAGE_SIZE. */
1425 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1426 gfc_character_storage_size
);
1427 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1428 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1430 /* IF condition: (stride == size_expr
1431 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1433 || 0 == size_expr. */
1434 block
->expr1
= gfc_get_expr ();
1435 block
->expr1
->ts
.type
= BT_LOGICAL
;
1436 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1437 block
->expr1
->expr_type
= EXPR_OP
;
1438 block
->expr1
->where
= gfc_current_locus
;
1440 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1442 /* byte_stride == size_expr */
1443 expr
= gfc_get_expr ();
1444 expr
->ts
.type
= BT_LOGICAL
;
1445 expr
->ts
.kind
= gfc_default_logical_kind
;
1446 expr
->expr_type
= EXPR_OP
;
1447 expr
->where
= gfc_current_locus
;
1448 expr
->value
.op
.op
= INTRINSIC_EQ
;
1450 = gfc_lval_expr_from_sym (byte_stride
);
1451 expr
->value
.op
.op2
= size_expr
;
1453 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1454 add is_contiguous check. */
1456 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1457 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1460 expr2
= gfc_get_expr ();
1461 expr2
->ts
.type
= BT_LOGICAL
;
1462 expr2
->ts
.kind
= gfc_default_logical_kind
;
1463 expr2
->expr_type
= EXPR_OP
;
1464 expr2
->where
= gfc_current_locus
;
1465 expr2
->value
.op
.op
= INTRINSIC_AND
;
1466 expr2
->value
.op
.op1
= expr
;
1467 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1471 block
->expr1
->value
.op
.op1
= expr
;
1473 /* 0 == size_expr */
1474 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1475 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1476 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1477 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1478 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1479 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1480 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1481 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1482 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1484 /* IF body: call final subroutine. */
1485 block
->next
= gfc_get_code (EXEC_CALL
);
1486 block
->next
->symtree
= fini
->proc_tree
;
1487 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1488 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1489 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1493 block
->block
= gfc_get_code (EXEC_IF
);
1494 block
= block
->block
;
1496 /* BLOCK ... END BLOCK. */
1497 block
->next
= gfc_get_code (EXEC_BLOCK
);
1498 block
= block
->next
;
1500 ns
= gfc_build_block_ns (sub_ns
);
1501 block
->ext
.block
.ns
= ns
;
1502 block
->ext
.block
.assoc
= NULL
;
1504 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1505 ptr2
->ts
.type
= BT_DERIVED
;
1506 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1507 ptr2
->attr
.flavor
= FL_VARIABLE
;
1508 ptr2
->attr
.pointer
= 1;
1509 ptr2
->attr
.artificial
= 1;
1510 gfc_set_sym_referenced (ptr2
);
1511 gfc_commit_symbol (ptr2
);
1513 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1514 tmp_array
->ts
.type
= BT_DERIVED
;
1515 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1516 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1517 tmp_array
->attr
.dimension
= 1;
1518 tmp_array
->attr
.artificial
= 1;
1519 tmp_array
->as
= gfc_get_array_spec();
1520 tmp_array
->attr
.intent
= INTENT_INOUT
;
1521 tmp_array
->as
->type
= AS_EXPLICIT
;
1522 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1524 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1526 gfc_expr
*shape_expr
;
1527 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1529 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1531 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1532 gfc_current_locus
, 3,
1533 gfc_lval_expr_from_sym (array
),
1534 gfc_get_int_expr (gfc_default_integer_kind
,
1536 gfc_get_int_expr (gfc_default_integer_kind
,
1538 gfc_index_integer_kind
));
1539 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1540 tmp_array
->as
->upper
[i
] = shape_expr
;
1542 gfc_set_sym_referenced (tmp_array
);
1543 gfc_commit_symbol (tmp_array
);
1546 iter
= gfc_get_iterator ();
1547 iter
->var
= gfc_lval_expr_from_sym (idx
);
1548 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1549 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1550 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1552 block
= gfc_get_code (EXEC_DO
);
1554 block
->ext
.iterator
= iter
;
1555 block
->block
= gfc_get_code (EXEC_DO
);
1557 /* Offset calculation for the new array: idx * size of type (in bytes). */
1558 offset2
= gfc_get_expr ();
1559 offset2
->expr_type
= EXPR_OP
;
1560 offset2
->where
= gfc_current_locus
;
1561 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1562 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1563 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1564 offset2
->ts
= byte_stride
->ts
;
1566 /* Offset calculation of "array". */
1567 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1568 byte_stride
, rank
, block
->block
, sub_ns
);
1571 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1572 + idx * stride, c_ptr), ptr). */
1573 block2
->next
= finalization_scalarizer (array
, ptr
,
1574 gfc_lval_expr_from_sym (offset
),
1576 block2
= block2
->next
;
1577 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1578 block2
= block2
->next
;
1581 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1582 block2
= block2
->next
;
1583 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1584 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1586 /* Call now the user's final subroutine. */
1587 block
->next
= gfc_get_code (EXEC_CALL
);
1588 block
= block
->next
;
1589 block
->symtree
= fini
->proc_tree
;
1590 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1591 block
->ext
.actual
= gfc_get_actual_arglist ();
1592 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1594 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1600 iter
= gfc_get_iterator ();
1601 iter
->var
= gfc_lval_expr_from_sym (idx
);
1602 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1603 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1604 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1606 block
->next
= gfc_get_code (EXEC_DO
);
1607 block
= block
->next
;
1608 block
->ext
.iterator
= iter
;
1609 block
->block
= gfc_get_code (EXEC_DO
);
1611 /* Offset calculation of "array". */
1612 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1613 byte_stride
, rank
, block
->block
, sub_ns
);
1616 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1617 + offset, c_ptr), ptr). */
1618 block2
->next
= finalization_scalarizer (array
, ptr
,
1619 gfc_lval_expr_from_sym (offset
),
1621 block2
= block2
->next
;
1622 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1623 gfc_copy_expr (offset2
), sub_ns
);
1624 block2
= block2
->next
;
1627 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1628 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1629 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1633 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1634 derived type "derived". The function first calls the approriate FINAL
1635 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1636 components (but not the inherited ones). Last, it calls the wrapper
1637 subroutine of the parent. The generated wrapper procedure takes as argument
1638 an assumed-rank array.
1639 If neither allocatable components nor FINAL subroutines exists, the vtab
1640 will contain a NULL pointer.
1641 The generated function has the form
1642 _final(assumed-rank array, stride, skip_corarray)
1643 where the array has to be contiguous (except of the lowest dimension). The
1644 stride (in bytes) is used to allow different sizes for ancestor types by
1645 skipping over the additionally added components in the scalarizer. If
1646 "fini_coarray" is false, coarray components are not finalized to allow for
1647 the correct semantic with intrinsic assignment. */
1650 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1651 const char *tname
, gfc_component
*vtab_final
)
1653 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1654 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1655 gfc_component
*comp
;
1656 gfc_namespace
*sub_ns
;
1657 gfc_code
*last_code
, *block
;
1659 bool finalizable_comp
= false;
1660 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1663 if (derived
->attr
.unlimited_polymorphic
)
1665 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1669 /* Search for the ancestor's finalizers. */
1670 if (derived
->attr
.extension
&& derived
->components
1671 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1672 || has_finalizer_component (derived
)))
1675 gfc_component
*comp
;
1677 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1678 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1679 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1681 ancestor_wrapper
= comp
->initializer
;
1686 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1687 components: Return a NULL() expression; we defer this a bit to have
1688 an interface declaration. */
1689 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1690 && !derived
->attr
.alloc_comp
1691 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1692 && !has_finalizer_component (derived
))
1694 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1695 gcc_assert (vtab_final
->ts
.interface
== NULL
);
1699 /* Check whether there are new allocatable components. */
1700 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1702 if (comp
== derived
->components
&& derived
->attr
.extension
1703 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1706 finalizable_comp
|= comp_is_finalizable (comp
);
1709 /* If there is no new finalizer and no new allocatable, return with
1710 an expr to the ancestor's one. */
1711 if (!finalizable_comp
1712 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1714 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1715 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1716 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1717 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1721 /* We now create a wrapper, which does the following:
1722 1. Call the suitable finalization subroutine for this type
1723 2. Loop over all noninherited allocatable components and noninherited
1724 components with allocatable components and DEALLOCATE those; this will
1725 take care of finalizers, coarray deregistering and allocatable
1727 3. Call the ancestor's finalizer. */
1729 /* Declare the wrapper function; it takes an assumed-rank array
1730 and a VALUE logical as arguments. */
1732 /* Set up the namespace. */
1733 sub_ns
= gfc_get_namespace (ns
, 0);
1734 sub_ns
->sibling
= ns
->contained
;
1735 ns
->contained
= sub_ns
;
1736 sub_ns
->resolved
= 1;
1738 /* Set up the procedure symbol. */
1739 name
= xasprintf ("__final_%s", tname
);
1740 gfc_get_symbol (name
, sub_ns
, &final
);
1741 sub_ns
->proc_name
= final
;
1742 final
->attr
.flavor
= FL_PROCEDURE
;
1743 final
->attr
.function
= 1;
1744 final
->attr
.pure
= 0;
1745 final
->attr
.recursive
= 1;
1746 final
->result
= final
;
1747 final
->ts
.type
= BT_INTEGER
;
1749 final
->attr
.artificial
= 1;
1750 final
->attr
.always_explicit
= 1;
1751 final
->attr
.if_source
= IFSRC_DECL
;
1752 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1753 final
->module
= ns
->proc_name
->name
;
1754 gfc_set_sym_referenced (final
);
1755 gfc_commit_symbol (final
);
1757 /* Set up formal argument. */
1758 gfc_get_symbol ("array", sub_ns
, &array
);
1759 array
->ts
.type
= BT_DERIVED
;
1760 array
->ts
.u
.derived
= derived
;
1761 array
->attr
.flavor
= FL_VARIABLE
;
1762 array
->attr
.dummy
= 1;
1763 array
->attr
.contiguous
= 1;
1764 array
->attr
.dimension
= 1;
1765 array
->attr
.artificial
= 1;
1766 array
->as
= gfc_get_array_spec();
1767 array
->as
->type
= AS_ASSUMED_RANK
;
1768 array
->as
->rank
= -1;
1769 array
->attr
.intent
= INTENT_INOUT
;
1770 gfc_set_sym_referenced (array
);
1771 final
->formal
= gfc_get_formal_arglist ();
1772 final
->formal
->sym
= array
;
1773 gfc_commit_symbol (array
);
1775 /* Set up formal argument. */
1776 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1777 byte_stride
->ts
.type
= BT_INTEGER
;
1778 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1779 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1780 byte_stride
->attr
.dummy
= 1;
1781 byte_stride
->attr
.value
= 1;
1782 byte_stride
->attr
.artificial
= 1;
1783 gfc_set_sym_referenced (byte_stride
);
1784 final
->formal
->next
= gfc_get_formal_arglist ();
1785 final
->formal
->next
->sym
= byte_stride
;
1786 gfc_commit_symbol (byte_stride
);
1788 /* Set up formal argument. */
1789 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1790 fini_coarray
->ts
.type
= BT_LOGICAL
;
1791 fini_coarray
->ts
.kind
= 1;
1792 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1793 fini_coarray
->attr
.dummy
= 1;
1794 fini_coarray
->attr
.value
= 1;
1795 fini_coarray
->attr
.artificial
= 1;
1796 gfc_set_sym_referenced (fini_coarray
);
1797 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1798 final
->formal
->next
->next
->sym
= fini_coarray
;
1799 gfc_commit_symbol (fini_coarray
);
1801 /* Local variables. */
1803 gfc_get_symbol ("idx", sub_ns
, &idx
);
1804 idx
->ts
.type
= BT_INTEGER
;
1805 idx
->ts
.kind
= gfc_index_integer_kind
;
1806 idx
->attr
.flavor
= FL_VARIABLE
;
1807 idx
->attr
.artificial
= 1;
1808 gfc_set_sym_referenced (idx
);
1809 gfc_commit_symbol (idx
);
1811 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1812 idx2
->ts
.type
= BT_INTEGER
;
1813 idx2
->ts
.kind
= gfc_index_integer_kind
;
1814 idx2
->attr
.flavor
= FL_VARIABLE
;
1815 idx2
->attr
.artificial
= 1;
1816 gfc_set_sym_referenced (idx2
);
1817 gfc_commit_symbol (idx2
);
1819 gfc_get_symbol ("offset", sub_ns
, &offset
);
1820 offset
->ts
.type
= BT_INTEGER
;
1821 offset
->ts
.kind
= gfc_index_integer_kind
;
1822 offset
->attr
.flavor
= FL_VARIABLE
;
1823 offset
->attr
.artificial
= 1;
1824 gfc_set_sym_referenced (offset
);
1825 gfc_commit_symbol (offset
);
1827 /* Create RANK expression. */
1828 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1829 gfc_current_locus
, 1,
1830 gfc_lval_expr_from_sym (array
));
1831 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1832 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1834 /* Create is_contiguous variable. */
1835 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1836 is_contiguous
->ts
.type
= BT_LOGICAL
;
1837 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1838 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1839 is_contiguous
->attr
.artificial
= 1;
1840 gfc_set_sym_referenced (is_contiguous
);
1841 gfc_commit_symbol (is_contiguous
);
1843 /* Create "sizes(0..rank)" variable, which contains the multiplied
1844 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1845 sizes(2) = sizes(1) * extent(dim=2) etc. */
1846 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1847 sizes
->ts
.type
= BT_INTEGER
;
1848 sizes
->ts
.kind
= gfc_index_integer_kind
;
1849 sizes
->attr
.flavor
= FL_VARIABLE
;
1850 sizes
->attr
.dimension
= 1;
1851 sizes
->attr
.artificial
= 1;
1852 sizes
->as
= gfc_get_array_spec();
1853 sizes
->attr
.intent
= INTENT_INOUT
;
1854 sizes
->as
->type
= AS_EXPLICIT
;
1855 sizes
->as
->rank
= 1;
1856 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1857 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1858 gfc_set_sym_referenced (sizes
);
1859 gfc_commit_symbol (sizes
);
1861 /* Create "strides(1..rank)" variable, which contains the strides per
1863 gfc_get_symbol ("strides", sub_ns
, &strides
);
1864 strides
->ts
.type
= BT_INTEGER
;
1865 strides
->ts
.kind
= gfc_index_integer_kind
;
1866 strides
->attr
.flavor
= FL_VARIABLE
;
1867 strides
->attr
.dimension
= 1;
1868 strides
->attr
.artificial
= 1;
1869 strides
->as
= gfc_get_array_spec();
1870 strides
->attr
.intent
= INTENT_INOUT
;
1871 strides
->as
->type
= AS_EXPLICIT
;
1872 strides
->as
->rank
= 1;
1873 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1874 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1875 gfc_set_sym_referenced (strides
);
1876 gfc_commit_symbol (strides
);
1879 /* Set return value to 0. */
1880 last_code
= gfc_get_code (EXEC_ASSIGN
);
1881 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1882 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1883 sub_ns
->code
= last_code
;
1885 /* Set: is_contiguous = .true. */
1886 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1887 last_code
= last_code
->next
;
1888 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1889 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1890 &gfc_current_locus
, true);
1892 /* Set: sizes(0) = 1. */
1893 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1894 last_code
= last_code
->next
;
1895 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1896 last_code
->expr1
->ref
= gfc_get_ref ();
1897 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1898 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1899 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1900 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1901 last_code
->expr1
->ref
->u
.ar
.start
[0]
1902 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1903 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1904 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1908 strides(idx) = _F._stride (array, dim=idx)
1909 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1910 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1914 iter
= gfc_get_iterator ();
1915 iter
->var
= gfc_lval_expr_from_sym (idx
);
1916 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1917 iter
->end
= gfc_copy_expr (rank
);
1918 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1919 last_code
->next
= gfc_get_code (EXEC_DO
);
1920 last_code
= last_code
->next
;
1921 last_code
->ext
.iterator
= iter
;
1922 last_code
->block
= gfc_get_code (EXEC_DO
);
1924 /* strides(idx) = _F._stride(array,dim=idx). */
1925 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1926 block
= last_code
->block
->next
;
1928 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1929 block
->expr1
->ref
= gfc_get_ref ();
1930 block
->expr1
->ref
->type
= REF_ARRAY
;
1931 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1932 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1933 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1934 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1935 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1937 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1938 gfc_current_locus
, 2,
1939 gfc_lval_expr_from_sym (array
),
1940 gfc_lval_expr_from_sym (idx
));
1942 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1943 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1944 block
= block
->next
;
1946 /* sizes(idx) = ... */
1947 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1948 block
->expr1
->ref
= gfc_get_ref ();
1949 block
->expr1
->ref
->type
= REF_ARRAY
;
1950 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1951 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1952 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1953 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1954 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1956 block
->expr2
= gfc_get_expr ();
1957 block
->expr2
->expr_type
= EXPR_OP
;
1958 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1959 block
->expr2
->where
= gfc_current_locus
;
1962 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1963 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1964 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1965 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1966 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1967 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1968 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1969 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1970 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1971 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1972 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1973 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1974 = gfc_lval_expr_from_sym (idx
);
1975 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1976 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1977 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1978 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1980 /* size(array, dim=idx, kind=index_kind). */
1981 block
->expr2
->value
.op
.op2
1982 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1983 gfc_current_locus
, 3,
1984 gfc_lval_expr_from_sym (array
),
1985 gfc_lval_expr_from_sym (idx
),
1986 gfc_get_int_expr (gfc_index_integer_kind
,
1988 gfc_index_integer_kind
));
1989 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1990 block
->expr2
->ts
= idx
->ts
;
1992 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1993 block
->next
= gfc_get_code (EXEC_IF
);
1994 block
= block
->next
;
1996 block
->block
= gfc_get_code (EXEC_IF
);
1997 block
= block
->block
;
1999 /* if condition: strides(idx) /= sizes(idx-1). */
2000 block
->expr1
= gfc_get_expr ();
2001 block
->expr1
->ts
.type
= BT_LOGICAL
;
2002 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
2003 block
->expr1
->expr_type
= EXPR_OP
;
2004 block
->expr1
->where
= gfc_current_locus
;
2005 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
2007 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
2008 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
2009 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2010 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2011 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2012 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2013 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
2014 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
2016 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
2017 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
2018 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
2019 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
2020 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
2021 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
2022 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2023 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
2024 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
2025 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
2026 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
2027 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
2028 = gfc_lval_expr_from_sym (idx
);
2029 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
2030 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2031 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
2032 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
2034 /* if body: is_contiguous = .false. */
2035 block
->next
= gfc_get_code (EXEC_ASSIGN
);
2036 block
= block
->next
;
2037 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
2038 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
2039 &gfc_current_locus
, false);
2041 /* Obtain the size (number of elements) of "array" MINUS ONE,
2042 which is used in the scalarization. */
2043 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
2044 nelem
->ts
.type
= BT_INTEGER
;
2045 nelem
->ts
.kind
= gfc_index_integer_kind
;
2046 nelem
->attr
.flavor
= FL_VARIABLE
;
2047 nelem
->attr
.artificial
= 1;
2048 gfc_set_sym_referenced (nelem
);
2049 gfc_commit_symbol (nelem
);
2051 /* nelem = sizes (rank) - 1. */
2052 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
2053 last_code
= last_code
->next
;
2055 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
2057 last_code
->expr2
= gfc_get_expr ();
2058 last_code
->expr2
->expr_type
= EXPR_OP
;
2059 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
2060 last_code
->expr2
->value
.op
.op2
2061 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2062 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
2063 last_code
->expr2
->where
= gfc_current_locus
;
2065 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
2066 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2067 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2068 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2069 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2070 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2071 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
2072 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2074 /* Call final subroutines. We now generate code like:
2076 integer, pointer :: ptr
2078 integer(c_intptr_t) :: i, addr
2080 select case (rank (array))
2082 ! If needed, the array is packed
2083 call final_rank3 (array)
2085 do i = 0, size (array)-1
2086 addr = transfer (c_loc (array), addr) + i * stride
2087 call c_f_pointer (transfer (addr, cptr), ptr)
2088 call elemental_final (ptr)
2092 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2094 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2096 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
2097 ptr
->ts
.type
= BT_DERIVED
;
2098 ptr
->ts
.u
.derived
= derived
;
2099 ptr
->attr
.flavor
= FL_VARIABLE
;
2100 ptr
->attr
.pointer
= 1;
2101 ptr
->attr
.artificial
= 1;
2102 gfc_set_sym_referenced (ptr
);
2103 gfc_commit_symbol (ptr
);
2105 fini
= derived
->f2k_derived
->finalizers
;
2107 /* Assumed rank finalizers can be called directly. The call takes care
2108 of setting up the descriptor. resolve_finalizers has already checked
2109 that this is the only finalizer for this kind/type (F2018: C790). */
2110 if (fini
->proc_tree
&& fini
->proc_tree
->n
.sym
->formal
->sym
->as
2111 && fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
== AS_ASSUMED_RANK
)
2113 last_code
->next
= gfc_get_code (EXEC_CALL
);
2114 last_code
->next
->symtree
= fini
->proc_tree
;
2115 last_code
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2116 last_code
->next
->ext
.actual
= gfc_get_actual_arglist ();
2117 last_code
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2119 last_code
= last_code
->next
;
2120 goto finish_assumed_rank
;
2123 /* SELECT CASE (RANK (array)). */
2124 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2125 last_code
= last_code
->next
;
2126 last_code
->expr1
= gfc_copy_expr (rank
);
2130 for (; fini
; fini
= fini
->next
)
2132 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2133 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2139 /* CASE (fini_rank). */
2142 block
->block
= gfc_get_code (EXEC_SELECT
);
2143 block
= block
->block
;
2147 block
= gfc_get_code (EXEC_SELECT
);
2148 last_code
->block
= block
;
2150 block
->ext
.block
.case_list
= gfc_get_case ();
2151 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2152 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2153 block
->ext
.block
.case_list
->low
2154 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2155 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2157 block
->ext
.block
.case_list
->low
2158 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2159 block
->ext
.block
.case_list
->high
2160 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2162 /* CALL fini_rank (array) - possibly with packing. */
2163 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2164 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2165 idx
, ptr
, nelem
, strides
,
2166 sizes
, idx2
, offset
, is_contiguous
,
2170 block
->next
= gfc_get_code (EXEC_CALL
);
2171 block
->next
->symtree
= fini
->proc_tree
;
2172 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2173 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2174 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2178 /* Elemental call - scalarized. */
2184 block
->block
= gfc_get_code (EXEC_SELECT
);
2185 block
= block
->block
;
2189 block
= gfc_get_code (EXEC_SELECT
);
2190 last_code
->block
= block
;
2192 block
->ext
.block
.case_list
= gfc_get_case ();
2195 iter
= gfc_get_iterator ();
2196 iter
->var
= gfc_lval_expr_from_sym (idx
);
2197 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2198 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2199 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2200 block
->next
= gfc_get_code (EXEC_DO
);
2201 block
= block
->next
;
2202 block
->ext
.iterator
= iter
;
2203 block
->block
= gfc_get_code (EXEC_DO
);
2205 /* Offset calculation. */
2206 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2207 byte_stride
, rank
, block
->block
,
2211 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2212 + offset, c_ptr), ptr). */
2214 = finalization_scalarizer (array
, ptr
,
2215 gfc_lval_expr_from_sym (offset
),
2217 block
= block
->next
;
2219 /* CALL final_elemental (array). */
2220 block
->next
= gfc_get_code (EXEC_CALL
);
2221 block
= block
->next
;
2222 block
->symtree
= fini_elem
->proc_tree
;
2223 block
->resolved_sym
= fini_elem
->proc_sym
;
2224 block
->ext
.actual
= gfc_get_actual_arglist ();
2225 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2229 finish_assumed_rank
:
2231 /* Finalize and deallocate allocatable components. The same manual
2232 scalarization is used as above. */
2234 if (finalizable_comp
)
2237 gfc_code
*block
= NULL
;
2241 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2242 ptr
->ts
.type
= BT_DERIVED
;
2243 ptr
->ts
.u
.derived
= derived
;
2244 ptr
->attr
.flavor
= FL_VARIABLE
;
2245 ptr
->attr
.pointer
= 1;
2246 ptr
->attr
.artificial
= 1;
2247 gfc_set_sym_referenced (ptr
);
2248 gfc_commit_symbol (ptr
);
2251 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2252 stat
->attr
.flavor
= FL_VARIABLE
;
2253 stat
->attr
.artificial
= 1;
2254 stat
->ts
.type
= BT_INTEGER
;
2255 stat
->ts
.kind
= gfc_default_integer_kind
;
2256 gfc_set_sym_referenced (stat
);
2257 gfc_commit_symbol (stat
);
2260 iter
= gfc_get_iterator ();
2261 iter
->var
= gfc_lval_expr_from_sym (idx
);
2262 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2263 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2264 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2265 last_code
->next
= gfc_get_code (EXEC_DO
);
2266 last_code
= last_code
->next
;
2267 last_code
->ext
.iterator
= iter
;
2268 last_code
->block
= gfc_get_code (EXEC_DO
);
2270 /* Offset calculation. */
2271 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2272 byte_stride
, rank
, last_code
->block
,
2276 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2277 + idx * stride, c_ptr), ptr). */
2278 block
->next
= finalization_scalarizer (array
, ptr
,
2279 gfc_lval_expr_from_sym(offset
),
2281 block
= block
->next
;
2283 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2285 if (comp
== derived
->components
&& derived
->attr
.extension
2286 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2289 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2290 stat
, fini_coarray
, &block
, sub_ns
);
2291 if (!last_code
->block
->next
)
2292 last_code
->block
->next
= block
;
2297 /* Call the finalizer of the ancestor. */
2298 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2300 last_code
->next
= gfc_get_code (EXEC_CALL
);
2301 last_code
= last_code
->next
;
2302 last_code
->symtree
= ancestor_wrapper
->symtree
;
2303 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2305 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2306 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2307 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2308 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2309 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2310 last_code
->ext
.actual
->next
->next
->expr
2311 = gfc_lval_expr_from_sym (fini_coarray
);
2314 gfc_free_expr (rank
);
2315 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2316 vtab_final
->ts
.interface
= final
;
2321 /* Add procedure pointers for all type-bound procedures to a vtab. */
2324 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2326 gfc_symbol
* super_type
;
2328 super_type
= gfc_get_derived_super_type (derived
);
2330 if (super_type
&& (super_type
!= derived
))
2332 /* Make sure that the PPCs appear in the same order as in the parent. */
2333 copy_vtab_proc_comps (super_type
, vtype
);
2334 /* Only needed to get the PPC initializers right. */
2335 add_procs_to_declared_vtab (super_type
, vtype
);
2338 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2339 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2341 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2342 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2346 /* Find or generate the symbol for a derived type's vtab. */
2349 gfc_find_derived_vtab (gfc_symbol
*derived
)
2352 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2353 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2354 gfc_gsymbol
*gsym
= NULL
;
2355 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2357 if (derived
->attr
.pdt_template
)
2360 /* Find the top-level namespace. */
2361 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2365 /* If the type is a class container, use the underlying derived type. */
2366 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2367 derived
= gfc_get_derived_super_type (derived
);
2375 /* Find the gsymbol for the module of use associated derived types. */
2376 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2377 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2378 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2382 /* Work in the gsymbol namespace if the top-level namespace is a module.
2383 This ensures that the vtable is unique, which is required since we use
2384 its address in SELECT TYPE. */
2385 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2386 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2391 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2394 get_unique_hashed_string (tname
, derived
);
2395 name
= xasprintf ("__vtab_%s", tname
);
2397 /* Look for the vtab symbol in various namespaces. */
2398 if (gsym
&& gsym
->ns
)
2400 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2405 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2407 gfc_find_symbol (name
, ns
, 0, &vtab
);
2409 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2413 gfc_get_symbol (name
, ns
, &vtab
);
2414 vtab
->ts
.type
= BT_DERIVED
;
2415 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2416 &gfc_current_locus
))
2418 vtab
->attr
.target
= 1;
2419 vtab
->attr
.save
= SAVE_IMPLICIT
;
2420 vtab
->attr
.vtab
= 1;
2421 vtab
->attr
.access
= ACCESS_PUBLIC
;
2422 gfc_set_sym_referenced (vtab
);
2424 name
= xasprintf ("__vtype_%s", tname
);
2426 gfc_find_symbol (name
, ns
, 0, &vtype
);
2430 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2433 /* Is this a derived type with recursive allocatable
2435 c
= (derived
->attr
.unlimited_polymorphic
2436 || derived
->attr
.abstract
) ?
2437 NULL
: derived
->components
;
2438 for (; c
; c
= c
->next
)
2439 if (c
->ts
.type
== BT_DERIVED
2440 && c
->ts
.u
.derived
== derived
)
2446 gfc_get_symbol (name
, ns
, &vtype
);
2447 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2448 &gfc_current_locus
))
2450 vtype
->attr
.access
= ACCESS_PUBLIC
;
2451 vtype
->attr
.vtype
= 1;
2452 gfc_set_sym_referenced (vtype
);
2454 /* Add component '_hash'. */
2455 if (!gfc_add_component (vtype
, "_hash", &c
))
2457 c
->ts
.type
= BT_INTEGER
;
2459 c
->attr
.access
= ACCESS_PRIVATE
;
2460 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2461 NULL
, derived
->hash_value
);
2463 /* Add component '_size'. */
2464 if (!gfc_add_component (vtype
, "_size", &c
))
2466 c
->ts
.type
= BT_INTEGER
;
2467 c
->ts
.kind
= gfc_size_kind
;
2468 c
->attr
.access
= ACCESS_PRIVATE
;
2469 /* Remember the derived type in ts.u.derived,
2470 so that the correct initializer can be set later on
2471 (in gfc_conv_structure). */
2472 c
->ts
.u
.derived
= derived
;
2473 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2476 /* Add component _extends. */
2477 if (!gfc_add_component (vtype
, "_extends", &c
))
2479 c
->attr
.pointer
= 1;
2480 c
->attr
.access
= ACCESS_PRIVATE
;
2481 if (!derived
->attr
.unlimited_polymorphic
)
2482 parent
= gfc_get_derived_super_type (derived
);
2488 parent_vtab
= gfc_find_derived_vtab (parent
);
2489 c
->ts
.type
= BT_DERIVED
;
2490 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2491 c
->initializer
= gfc_get_expr ();
2492 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2493 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2494 0, &c
->initializer
->symtree
);
2498 c
->ts
.type
= BT_DERIVED
;
2499 c
->ts
.u
.derived
= vtype
;
2500 c
->initializer
= gfc_get_null_expr (NULL
);
2503 if (!derived
->attr
.unlimited_polymorphic
2504 && derived
->components
== NULL
2505 && !derived
->attr
.zero_comp
)
2507 /* At this point an error must have occurred.
2508 Prevent further errors on the vtype components. */
2513 /* Add component _def_init. */
2514 if (!gfc_add_component (vtype
, "_def_init", &c
))
2516 c
->attr
.pointer
= 1;
2517 c
->attr
.artificial
= 1;
2518 c
->attr
.access
= ACCESS_PRIVATE
;
2519 c
->ts
.type
= BT_DERIVED
;
2520 c
->ts
.u
.derived
= derived
;
2521 if (derived
->attr
.unlimited_polymorphic
2522 || derived
->attr
.abstract
)
2523 c
->initializer
= gfc_get_null_expr (NULL
);
2526 /* Construct default initialization variable. */
2528 name
= xasprintf ("__def_init_%s", tname
);
2529 gfc_get_symbol (name
, ns
, &def_init
);
2530 def_init
->attr
.target
= 1;
2531 def_init
->attr
.artificial
= 1;
2532 def_init
->attr
.save
= SAVE_IMPLICIT
;
2533 def_init
->attr
.access
= ACCESS_PUBLIC
;
2534 def_init
->attr
.flavor
= FL_VARIABLE
;
2535 gfc_set_sym_referenced (def_init
);
2536 def_init
->ts
.type
= BT_DERIVED
;
2537 def_init
->ts
.u
.derived
= derived
;
2538 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2540 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2543 /* Add component _copy. */
2544 if (!gfc_add_component (vtype
, "_copy", &c
))
2546 c
->attr
.proc_pointer
= 1;
2547 c
->attr
.access
= ACCESS_PRIVATE
;
2548 c
->tb
= XCNEW (gfc_typebound_proc
);
2550 if (derived
->attr
.unlimited_polymorphic
2551 || derived
->attr
.abstract
)
2552 c
->initializer
= gfc_get_null_expr (NULL
);
2555 /* Set up namespace. */
2556 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2557 sub_ns
->sibling
= ns
->contained
;
2558 ns
->contained
= sub_ns
;
2559 sub_ns
->resolved
= 1;
2560 /* Set up procedure symbol. */
2562 name
= xasprintf ("__copy_%s", tname
);
2563 gfc_get_symbol (name
, sub_ns
, ©
);
2564 sub_ns
->proc_name
= copy
;
2565 copy
->attr
.flavor
= FL_PROCEDURE
;
2566 copy
->attr
.subroutine
= 1;
2567 copy
->attr
.pure
= 1;
2568 copy
->attr
.artificial
= 1;
2569 copy
->attr
.if_source
= IFSRC_DECL
;
2570 /* This is elemental so that arrays are automatically
2571 treated correctly by the scalarizer. */
2572 copy
->attr
.elemental
= 1;
2573 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2574 copy
->module
= ns
->proc_name
->name
;
2575 gfc_set_sym_referenced (copy
);
2576 /* Set up formal arguments. */
2577 gfc_get_symbol ("src", sub_ns
, &src
);
2578 src
->ts
.type
= BT_DERIVED
;
2579 src
->ts
.u
.derived
= derived
;
2580 src
->attr
.flavor
= FL_VARIABLE
;
2581 src
->attr
.dummy
= 1;
2582 src
->attr
.artificial
= 1;
2583 src
->attr
.intent
= INTENT_IN
;
2584 gfc_set_sym_referenced (src
);
2585 copy
->formal
= gfc_get_formal_arglist ();
2586 copy
->formal
->sym
= src
;
2587 gfc_get_symbol ("dst", sub_ns
, &dst
);
2588 dst
->ts
.type
= BT_DERIVED
;
2589 dst
->ts
.u
.derived
= derived
;
2590 dst
->attr
.flavor
= FL_VARIABLE
;
2591 dst
->attr
.dummy
= 1;
2592 dst
->attr
.artificial
= 1;
2593 dst
->attr
.intent
= INTENT_INOUT
;
2594 gfc_set_sym_referenced (dst
);
2595 copy
->formal
->next
= gfc_get_formal_arglist ();
2596 copy
->formal
->next
->sym
= dst
;
2598 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2599 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2600 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2601 /* Set initializer. */
2602 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2603 c
->ts
.interface
= copy
;
2606 /* Add component _final, which contains a procedure pointer to
2607 a wrapper which handles both the freeing of allocatable
2608 components and the calls to finalization subroutines.
2609 Note: The actual wrapper function can only be generated
2610 at resolution time. */
2611 if (!gfc_add_component (vtype
, "_final", &c
))
2613 c
->attr
.proc_pointer
= 1;
2614 c
->attr
.access
= ACCESS_PRIVATE
;
2615 c
->attr
.artificial
= 1;
2616 c
->tb
= XCNEW (gfc_typebound_proc
);
2618 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2620 /* Add component _deallocate. */
2621 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2623 c
->attr
.proc_pointer
= 1;
2624 c
->attr
.access
= ACCESS_PRIVATE
;
2625 c
->tb
= XCNEW (gfc_typebound_proc
);
2627 if (derived
->attr
.unlimited_polymorphic
2628 || derived
->attr
.abstract
2630 c
->initializer
= gfc_get_null_expr (NULL
);
2633 /* Set up namespace. */
2634 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2636 sub_ns
->sibling
= ns
->contained
;
2637 ns
->contained
= sub_ns
;
2638 sub_ns
->resolved
= 1;
2639 /* Set up procedure symbol. */
2641 name
= xasprintf ("__deallocate_%s", tname
);
2642 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2643 sub_ns
->proc_name
= dealloc
;
2644 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2645 dealloc
->attr
.subroutine
= 1;
2646 dealloc
->attr
.pure
= 1;
2647 dealloc
->attr
.artificial
= 1;
2648 dealloc
->attr
.if_source
= IFSRC_DECL
;
2650 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2651 dealloc
->module
= ns
->proc_name
->name
;
2652 gfc_set_sym_referenced (dealloc
);
2653 /* Set up formal argument. */
2654 gfc_get_symbol ("arg", sub_ns
, &arg
);
2655 arg
->ts
.type
= BT_DERIVED
;
2656 arg
->ts
.u
.derived
= derived
;
2657 arg
->attr
.flavor
= FL_VARIABLE
;
2658 arg
->attr
.dummy
= 1;
2659 arg
->attr
.artificial
= 1;
2660 arg
->attr
.intent
= INTENT_INOUT
;
2661 arg
->attr
.dimension
= 1;
2662 arg
->attr
.allocatable
= 1;
2663 arg
->as
= gfc_get_array_spec();
2664 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2666 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2668 gfc_set_sym_referenced (arg
);
2669 dealloc
->formal
= gfc_get_formal_arglist ();
2670 dealloc
->formal
->sym
= arg
;
2672 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2673 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2674 sub_ns
->code
->ext
.alloc
.list
->expr
2675 = gfc_lval_expr_from_sym (arg
);
2676 /* Set initializer. */
2677 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2678 c
->ts
.interface
= dealloc
;
2681 /* Add procedure pointers for type-bound procedures. */
2682 if (!derived
->attr
.unlimited_polymorphic
)
2683 add_procs_to_declared_vtab (derived
, vtype
);
2687 vtab
->ts
.u
.derived
= vtype
;
2688 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2696 /* It is unexpected to have some symbols added at resolution or code
2697 generation time. We commit the changes in order to keep a clean state. */
2700 gfc_commit_symbol (vtab
);
2702 gfc_commit_symbol (vtype
);
2704 gfc_commit_symbol (def_init
);
2706 gfc_commit_symbol (copy
);
2708 gfc_commit_symbol (src
);
2710 gfc_commit_symbol (dst
);
2712 gfc_commit_symbol (dealloc
);
2714 gfc_commit_symbol (arg
);
2717 gfc_undo_symbols ();
2723 /* Check if a derived type is finalizable. That is the case if it
2724 (1) has a FINAL subroutine or
2725 (2) has a nonpointer nonallocatable component of finalizable type.
2726 If it is finalizable, return an expression containing the
2727 finalization wrapper. */
2730 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2735 /* (1) Check for FINAL subroutines. */
2736 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2739 /* (2) Check for components of finalizable type. */
2740 for (c
= derived
->components
; c
; c
= c
->next
)
2741 if (c
->ts
.type
== BT_DERIVED
2742 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2743 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2749 /* Make sure vtab is generated. */
2750 vtab
= gfc_find_derived_vtab (derived
);
2753 /* Return finalizer expression. */
2754 gfc_component
*final
;
2755 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2756 gcc_assert (strcmp (final
->name
, "_final") == 0);
2757 gcc_assert (final
->initializer
2758 && final
->initializer
->expr_type
!= EXPR_NULL
);
2759 *final_expr
= final
->initializer
;
2766 gfc_may_be_finalized (gfc_typespec ts
)
2768 return (ts
.type
== BT_CLASS
|| (ts
.type
== BT_DERIVED
2769 && ts
.u
.derived
&& gfc_is_finalizable (ts
.u
.derived
, NULL
)));
2773 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2774 needed to support unlimited polymorphism. */
2777 find_intrinsic_vtab (gfc_typespec
*ts
)
2780 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2781 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2783 /* Find the top-level namespace. */
2784 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2790 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2793 /* Encode all types as TYPENAME_KIND_ including especially character
2794 arrays, whose length is now consistently stored in the _len component
2795 of the class-variable. */
2796 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2797 name
= xasprintf ("__vtab_%s", tname
);
2799 /* Look for the vtab symbol in the top-level namespace only. */
2800 gfc_find_symbol (name
, ns
, 0, &vtab
);
2804 gfc_get_symbol (name
, ns
, &vtab
);
2805 vtab
->ts
.type
= BT_DERIVED
;
2806 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2807 &gfc_current_locus
))
2809 vtab
->attr
.target
= 1;
2810 vtab
->attr
.save
= SAVE_IMPLICIT
;
2811 vtab
->attr
.vtab
= 1;
2812 vtab
->attr
.access
= ACCESS_PUBLIC
;
2813 gfc_set_sym_referenced (vtab
);
2815 name
= xasprintf ("__vtype_%s", tname
);
2817 gfc_find_symbol (name
, ns
, 0, &vtype
);
2822 gfc_namespace
*sub_ns
;
2823 gfc_namespace
*contained
;
2827 gfc_get_symbol (name
, ns
, &vtype
);
2828 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2829 &gfc_current_locus
))
2831 vtype
->attr
.access
= ACCESS_PUBLIC
;
2832 vtype
->attr
.vtype
= 1;
2833 gfc_set_sym_referenced (vtype
);
2835 /* Add component '_hash'. */
2836 if (!gfc_add_component (vtype
, "_hash", &c
))
2838 c
->ts
.type
= BT_INTEGER
;
2840 c
->attr
.access
= ACCESS_PRIVATE
;
2841 hash
= gfc_intrinsic_hash_value (ts
);
2842 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2845 /* Add component '_size'. */
2846 if (!gfc_add_component (vtype
, "_size", &c
))
2848 c
->ts
.type
= BT_INTEGER
;
2849 c
->ts
.kind
= gfc_size_kind
;
2850 c
->attr
.access
= ACCESS_PRIVATE
;
2852 /* Build a minimal expression to make use of
2853 target-memory.cc/gfc_element_size for 'size'. Special handling
2854 for character arrays, that are not constant sized: to support
2855 len (str) * kind, only the kind information is stored in the
2857 e
= gfc_get_expr ();
2859 e
->expr_type
= EXPR_VARIABLE
;
2860 if (ts
->type
== BT_CHARACTER
)
2863 gfc_element_size (e
, &e_size
);
2864 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2869 /* Add component _extends. */
2870 if (!gfc_add_component (vtype
, "_extends", &c
))
2872 c
->attr
.pointer
= 1;
2873 c
->attr
.access
= ACCESS_PRIVATE
;
2874 c
->ts
.type
= BT_VOID
;
2875 c
->initializer
= gfc_get_null_expr (NULL
);
2877 /* Add component _def_init. */
2878 if (!gfc_add_component (vtype
, "_def_init", &c
))
2880 c
->attr
.pointer
= 1;
2881 c
->attr
.access
= ACCESS_PRIVATE
;
2882 c
->ts
.type
= BT_VOID
;
2883 c
->initializer
= gfc_get_null_expr (NULL
);
2885 /* Add component _copy. */
2886 if (!gfc_add_component (vtype
, "_copy", &c
))
2888 c
->attr
.proc_pointer
= 1;
2889 c
->attr
.access
= ACCESS_PRIVATE
;
2890 c
->tb
= XCNEW (gfc_typebound_proc
);
2894 if (ts
->type
!= BT_CHARACTER
)
2895 name
= xasprintf ("__copy_%s", tname
);
2898 /* __copy is always the same for characters.
2899 Check to see if copy function already exists. */
2900 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2901 contained
= ns
->contained
;
2902 for (; contained
; contained
= contained
->sibling
)
2903 if (contained
->proc_name
2904 && strcmp (name
, contained
->proc_name
->name
) == 0)
2906 copy
= contained
->proc_name
;
2911 /* Set up namespace. */
2912 sub_ns
= gfc_get_namespace (ns
, 0);
2913 sub_ns
->sibling
= ns
->contained
;
2914 ns
->contained
= sub_ns
;
2915 sub_ns
->resolved
= 1;
2916 /* Set up procedure symbol. */
2917 gfc_get_symbol (name
, sub_ns
, ©
);
2918 sub_ns
->proc_name
= copy
;
2919 copy
->attr
.flavor
= FL_PROCEDURE
;
2920 copy
->attr
.subroutine
= 1;
2921 copy
->attr
.pure
= 1;
2922 copy
->attr
.if_source
= IFSRC_DECL
;
2923 /* This is elemental so that arrays are automatically
2924 treated correctly by the scalarizer. */
2925 copy
->attr
.elemental
= 1;
2926 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2927 copy
->module
= ns
->proc_name
->name
;
2928 gfc_set_sym_referenced (copy
);
2929 /* Set up formal arguments. */
2930 gfc_get_symbol ("src", sub_ns
, &src
);
2931 src
->ts
.type
= ts
->type
;
2932 src
->ts
.kind
= ts
->kind
;
2933 src
->attr
.flavor
= FL_VARIABLE
;
2934 src
->attr
.dummy
= 1;
2935 src
->attr
.intent
= INTENT_IN
;
2936 gfc_set_sym_referenced (src
);
2937 copy
->formal
= gfc_get_formal_arglist ();
2938 copy
->formal
->sym
= src
;
2939 gfc_get_symbol ("dst", sub_ns
, &dst
);
2940 dst
->ts
.type
= ts
->type
;
2941 dst
->ts
.kind
= ts
->kind
;
2942 dst
->attr
.flavor
= FL_VARIABLE
;
2943 dst
->attr
.dummy
= 1;
2944 dst
->attr
.intent
= INTENT_INOUT
;
2945 gfc_set_sym_referenced (dst
);
2946 copy
->formal
->next
= gfc_get_formal_arglist ();
2947 copy
->formal
->next
->sym
= dst
;
2949 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2950 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2951 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2953 /* Set initializer. */
2954 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2955 c
->ts
.interface
= copy
;
2957 /* Add component _final. */
2958 if (!gfc_add_component (vtype
, "_final", &c
))
2960 c
->attr
.proc_pointer
= 1;
2961 c
->attr
.access
= ACCESS_PRIVATE
;
2962 c
->attr
.artificial
= 1;
2963 c
->tb
= XCNEW (gfc_typebound_proc
);
2965 c
->initializer
= gfc_get_null_expr (NULL
);
2967 vtab
->ts
.u
.derived
= vtype
;
2968 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2976 /* It is unexpected to have some symbols added at resolution or code
2977 generation time. We commit the changes in order to keep a clean state. */
2980 gfc_commit_symbol (vtab
);
2982 gfc_commit_symbol (vtype
);
2984 gfc_commit_symbol (copy
);
2986 gfc_commit_symbol (src
);
2988 gfc_commit_symbol (dst
);
2991 gfc_undo_symbols ();
2997 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
3000 gfc_find_vtab (gfc_typespec
*ts
)
3007 return gfc_find_derived_vtab (ts
->u
.derived
);
3009 if (ts
->u
.derived
->attr
.is_class
3010 && ts
->u
.derived
->components
3011 && ts
->u
.derived
->components
->ts
.u
.derived
)
3012 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
3016 return find_intrinsic_vtab (ts
);
3021 /* General worker function to find either a type-bound procedure or a
3022 type-bound user operator. */
3025 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
3026 const char* name
, bool noaccess
, bool uop
,
3032 /* Set default to failure. */
3036 if (derived
->f2k_derived
)
3037 /* Set correct symbol-root. */
3038 root
= (uop
? derived
->f2k_derived
->tb_uop_root
3039 : derived
->f2k_derived
->tb_sym_root
);
3043 /* Try to find it in the current type's namespace. */
3044 res
= gfc_find_symtree (root
, name
);
3045 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
3051 if (!noaccess
&& derived
->attr
.use_assoc
3052 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
3055 gfc_error ("%qs of %qs is PRIVATE at %L",
3056 name
, derived
->name
, where
);
3064 /* Otherwise, recurse on parent type if derived is an extension. */
3065 if (derived
->attr
.extension
)
3067 gfc_symbol
* super_type
;
3068 super_type
= gfc_get_derived_super_type (derived
);
3069 gcc_assert (super_type
);
3071 return find_typebound_proc_uop (super_type
, t
, name
,
3072 noaccess
, uop
, where
);
3075 /* Nothing found. */
3080 /* Find a type-bound procedure or user operator by name for a derived-type
3081 (looking recursively through the super-types). */
3084 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
3085 const char* name
, bool noaccess
, locus
* where
)
3087 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
3091 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
3092 const char* name
, bool noaccess
, locus
* where
)
3094 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
3098 /* Find a type-bound intrinsic operator looking recursively through the
3099 super-type hierarchy. */
3102 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
3103 gfc_intrinsic_op op
, bool noaccess
,
3106 gfc_typebound_proc
* res
;
3108 /* Set default to failure. */
3112 /* Try to find it in the current type's namespace. */
3113 if (derived
->f2k_derived
)
3114 res
= derived
->f2k_derived
->tb_op
[op
];
3119 if (res
&& !res
->error
)
3125 if (!noaccess
&& derived
->attr
.use_assoc
3126 && res
->access
== ACCESS_PRIVATE
)
3129 gfc_error ("%qs of %qs is PRIVATE at %L",
3130 gfc_op2string (op
), derived
->name
, where
);
3138 /* Otherwise, recurse on parent type if derived is an extension. */
3139 if (derived
->attr
.extension
)
3141 gfc_symbol
* super_type
;
3142 super_type
= gfc_get_derived_super_type (derived
);
3143 gcc_assert (super_type
);
3145 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3149 /* Nothing found. */
3154 /* Get a typebound-procedure symtree or create and insert it if not yet
3155 present. This is like a very simplified version of gfc_get_sym_tree for
3156 tbp-symtrees rather than regular ones. */
3159 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3161 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3162 return result
? result
: gfc_new_symtree (root
, name
);