1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2016 Free Software Foundation, Inc.
3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 and Janus Weil <janus@gcc.gnu.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* class.c -- This file contains the front end functions needed to service
24 the implementation of Fortran 2003 polymorphism and other
25 object-oriented features. */
28 /* Outline of the internal representation:
30 Each CLASS variable is encapsulated by a class container, which is a
31 structure with two fields:
32 * _data: A pointer to the actual data of the variable. This field has the
33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...).
35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
37 Only for unlimited polymorphic classes:
38 * _len: An integer(4) to store the string length when the unlimited
39 polymorphic pointer is used to point to a char array. The '_len'
40 component will be zero when no character array is stored in
43 For each derived type we set up a "vtable" entry, i.e. a structure with the
45 * _hash: A hash value serving as a unique identifier for this type.
46 * _size: The size in bytes of the derived type.
47 * _extends: A pointer to the vtable entry of the parent derived type.
48 * _def_init: A pointer to a default initialized variable of this type.
49 * _copy: A procedure pointer to a copying procedure.
50 * _final: A procedure pointer to a wrapper function, which frees
51 allocatable components and calls FINAL subroutines.
53 After these follow procedure pointer components for the specific
54 type-bound procedures. */
59 #include "coretypes.h"
61 #include "constructor.h"
62 #include "target-memory.h"
64 /* Inserts a derived type component reference in a data reference chain.
65 TS: base type of the ref chain so far, in which we will pick the component
66 REF: the address of the GFC_REF pointer to update
67 NAME: name of the component to insert
68 Note that component insertion makes sense only if we are at the end of
69 the chain (*REF == NULL) or if we are adding a missing "_data" component
70 to access the actual contents of a class object. */
73 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
78 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
79 type_sym
= ts
->u
.derived
;
81 gfc_find_component (type_sym
, name
, true, true, &new_ref
);
82 gcc_assert (new_ref
->u
.c
.component
);
84 new_ref
= new_ref
->next
;
91 /* We need to update the base type in the trailing reference chain to
92 that of the new component. */
94 gcc_assert (strcmp (name
, "_data") == 0);
96 if (new_ref
->next
->type
== REF_COMPONENT
)
98 else if (new_ref
->next
->type
== REF_ARRAY
99 && new_ref
->next
->next
100 && new_ref
->next
->next
->type
== REF_COMPONENT
)
101 next
= new_ref
->next
->next
;
105 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
106 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
107 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
115 /* Tells whether we need to add a "_data" reference to access REF subobject
116 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
117 object accessed by REF is a variable; in other words it is a full object,
121 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
123 /* Only class containers may need the "_data" reference. */
124 if (ts
->type
!= BT_CLASS
)
127 /* Accessing a class container with an array reference is certainly wrong. */
128 if (ref
->type
!= REF_COMPONENT
)
131 /* Accessing the class container's fields is fine. */
132 if (ref
->u
.c
.component
->name
[0] == '_')
135 /* At this point we have a class container with a non class container's field
136 component reference. We don't want to add the "_data" component if we are
137 at the first reference and the symbol's type is an extended derived type.
138 In that case, conv_parent_component_references will do the right thing so
139 it is not absolutely necessary. Omitting it prevents a regression (see
140 class_41.f03) in the interface mapping mechanism. When evaluating string
141 lengths depending on dummy arguments, we create a fake symbol with a type
142 equal to that of the dummy type. However, because of type extension,
143 the backend type (corresponding to the actual argument) can have a
144 different (extended) type. Adding the "_data" component explicitly, using
145 the base type, confuses the gfc_conv_component_ref code which deals with
146 the extended type. */
147 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
150 /* We have a class container with a non class container's field component
151 reference that doesn't fall into the above. */
156 /* Browse through a data reference chain and add the missing "_data" references
157 when a subobject of a class object is accessed without it.
158 Note that it doesn't add the "_data" reference when the class container
159 is the last element in the reference chain. */
162 gfc_fix_class_refs (gfc_expr
*e
)
167 if ((e
->expr_type
!= EXPR_VARIABLE
168 && e
->expr_type
!= EXPR_FUNCTION
)
169 || (e
->expr_type
== EXPR_FUNCTION
170 && e
->value
.function
.isym
!= NULL
))
173 if (e
->expr_type
== EXPR_VARIABLE
)
174 ts
= &e
->symtree
->n
.sym
->ts
;
179 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
180 if (e
->value
.function
.esym
!= NULL
)
181 func
= e
->value
.function
.esym
;
183 func
= e
->symtree
->n
.sym
;
185 if (func
->result
!= NULL
)
186 ts
= &func
->result
->ts
;
191 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
193 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
194 insert_component_ref (ts
, ref
, "_data");
196 if ((*ref
)->type
== REF_COMPONENT
)
197 ts
= &(*ref
)->u
.c
.component
->ts
;
202 /* Insert a reference to the component of the given name.
203 Only to be used with CLASS containers and vtables. */
206 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
209 gfc_ref
**tail
= &(e
->ref
);
210 gfc_ref
*ref
, *next
= NULL
;
211 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
212 while (*tail
!= NULL
)
214 if ((*tail
)->type
== REF_COMPONENT
)
216 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
218 && (*tail
)->next
->type
== REF_ARRAY
219 && (*tail
)->next
->next
== NULL
)
221 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
223 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
225 tail
= &((*tail
)->next
);
227 if (derived
->components
&& derived
->components
->next
&&
228 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
229 derived
->components
->next
->ts
.u
.derived
== NULL
)
231 /* Fix up missing vtype. */
232 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
234 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
236 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
239 /* Avoid losing memory. */
240 gfc_free_ref_list (*tail
);
241 c
= gfc_find_component (derived
, name
, true, true, tail
);
244 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
253 /* This is used to add both the _data component reference and an array
254 reference to class expressions. Used in translation of intrinsic
255 array inquiry functions. */
258 gfc_add_class_array_ref (gfc_expr
*e
)
260 int rank
= CLASS_DATA (e
)->as
->rank
;
261 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
263 gfc_add_data_component (e
);
265 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
268 if (ref
->type
!= REF_ARRAY
)
270 ref
->next
= gfc_get_ref ();
272 ref
->type
= REF_ARRAY
;
273 ref
->u
.ar
.type
= AR_FULL
;
279 /* Unfortunately, class array expressions can appear in various conditions;
280 with and without both _data component and an arrayspec. This function
281 deals with that variability. The previous reference to 'ref' is to a
285 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
287 bool no_data
= false;
288 bool with_data
= false;
290 /* An array reference with no _data component. */
291 if (ref
&& ref
->type
== REF_ARRAY
293 && ref
->u
.ar
.type
!= AR_ELEMENT
)
296 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
300 /* Cover cases where _data appears, with or without an array ref. */
301 if (ref
&& ref
->type
== REF_COMPONENT
302 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
310 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
312 && ref
->type
== REF_COMPONENT
313 && ref
->next
->type
== REF_ARRAY
314 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
318 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
322 return no_data
|| with_data
;
326 /* Returns true if the expression contains a reference to a class
327 array. Notice that class array elements return false. */
330 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
340 /* Is this a class array object? ie. Is the symbol of type class? */
342 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
343 && CLASS_DATA (e
->symtree
->n
.sym
)
344 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
345 && class_array_ref_detected (e
->ref
, full_array
))
348 /* Or is this a class array component reference? */
349 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
351 if (ref
->type
== REF_COMPONENT
352 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
353 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
354 && class_array_ref_detected (ref
->next
, full_array
))
362 /* Returns true if the expression is a reference to a class
363 scalar. This function is necessary because such expressions
364 can be dressed with a reference to the _data component and so
365 have a type other than BT_CLASS. */
368 gfc_is_class_scalar_expr (gfc_expr
*e
)
375 /* Is this a class object? */
377 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
378 && CLASS_DATA (e
->symtree
->n
.sym
)
379 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
381 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
382 && e
->ref
->next
== NULL
)))
385 /* Or is the final reference BT_CLASS or _data? */
386 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
388 if (ref
->type
== REF_COMPONENT
389 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
390 && CLASS_DATA (ref
->u
.c
.component
)
391 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
392 && (ref
->next
== NULL
393 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
394 && ref
->next
->next
== NULL
)))
402 /* Tells whether the expression E is a reference to a (scalar) class container.
403 Scalar because array class containers usually have an array reference after
404 them, and gfc_fix_class_refs will add the missing "_data" component reference
408 gfc_is_class_container_ref (gfc_expr
*e
)
413 if (e
->expr_type
!= EXPR_VARIABLE
)
414 return e
->ts
.type
== BT_CLASS
;
416 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
421 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
423 if (ref
->type
!= REF_COMPONENT
)
425 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
435 /* Build an initializer for CLASS pointers,
436 initializing the _data component to the init_expr (or NULL) and the _vptr
437 component to the corresponding type (or the declared type, given by ts). */
440 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
444 gfc_symbol
*vtab
= NULL
;
446 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
447 vtab
= gfc_find_vtab (&init_expr
->ts
);
449 vtab
= gfc_find_vtab (ts
);
451 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
452 &ts
->u
.derived
->declared_at
);
455 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
457 gfc_constructor
*ctor
= gfc_constructor_get();
458 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
459 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
460 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
461 ctor
->expr
= gfc_copy_expr (init_expr
);
463 ctor
->expr
= gfc_get_null_expr (NULL
);
464 gfc_constructor_append (&init
->value
.constructor
, ctor
);
471 /* Create a unique string identifier for a derived type, composed of its name
472 and module name. This is used to construct unique names for the class
473 containers and vtab symbols. */
476 get_unique_type_string (char *string
, gfc_symbol
*derived
)
478 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
479 if (derived
->attr
.unlimited_polymorphic
)
480 strcpy (dt_name
, "STAR");
482 strcpy (dt_name
, gfc_dt_upper_string (derived
->name
));
483 if (derived
->attr
.unlimited_polymorphic
)
484 sprintf (string
, "_%s", dt_name
);
485 else if (derived
->module
)
486 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
487 else if (derived
->ns
->proc_name
)
488 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
490 sprintf (string
, "_%s", dt_name
);
494 /* A relative of 'get_unique_type_string' which makes sure the generated
495 string will not be too long (replacing it by a hash string if needed). */
498 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
500 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
501 get_unique_type_string (&tmp
[0], derived
);
502 /* If string is too long, use hash value in hex representation (allow for
503 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
504 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
505 where %d is the (co)rank which can be up to n = 15. */
506 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
508 int h
= gfc_hash_value (derived
);
509 sprintf (string
, "%X", h
);
512 strcpy (string
, tmp
);
516 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
519 gfc_hash_value (gfc_symbol
*sym
)
521 unsigned int hash
= 0;
522 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
525 get_unique_type_string (&c
[0], sym
);
528 for (i
= 0; i
< len
; i
++)
529 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
531 /* Return the hash but take the modulus for the sake of module read,
532 even though this slightly increases the chance of collision. */
533 return (hash
% 100000000);
537 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
540 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
542 unsigned int hash
= 0;
543 const char *c
= gfc_typename (ts
);
548 for (i
= 0; i
< len
; i
++)
549 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
551 /* Return the hash but take the modulus for the sake of module read,
552 even though this slightly increases the chance of collision. */
553 return (hash
% 100000000);
557 /* Get the _len component from a class/derived object storing a string.
558 For unlimited polymorphic entities a ref to the _data component is available
559 while a ref to the _len component is needed. This routine traverese the
560 ref-chain and strips the last ref to a _data from it replacing it with a
561 ref to the _len component. */
564 gfc_get_len_component (gfc_expr
*e
)
567 gfc_ref
*ref
, **last
;
569 ptr
= gfc_copy_expr (e
);
571 /* We need to remove the last _data component ref from ptr. */
577 && ref
->type
== REF_COMPONENT
578 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
580 gfc_free_ref_list (ref
);
587 /* And replace if with a ref to the _len component. */
588 gfc_add_len_component (ptr
);
593 /* Build a polymorphic CLASS entity, using the symbol that comes from
594 build_sym. A CLASS entity is represented by an encapsulating type,
595 which contains the declared type as '_data' component, plus a pointer
596 component '_vptr' which determines the dynamic type. When this CLASS
597 entity is unlimited polymorphic, then also add a component '_len' to
598 store the length of string when that is stored in it. */
601 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
604 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
613 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
615 gfc_error ("Assumed size polymorphic objects or components, such "
616 "as that at %C, have not yet been implemented");
621 /* Class container has already been built. */
624 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
625 || attr
->select_type_temporary
|| attr
->associate_var
;
628 /* We can not build the class container yet. */
631 /* Determine the name of the encapsulating type. */
632 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
633 get_unique_hashed_string (tname
, ts
->u
.derived
);
634 if ((*as
) && attr
->allocatable
)
635 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
636 else if ((*as
) && attr
->pointer
)
637 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
639 sprintf (name
, "__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
640 else if (attr
->pointer
)
641 sprintf (name
, "__class_%s_p", tname
);
642 else if (attr
->allocatable
)
643 sprintf (name
, "__class_%s_a", tname
);
645 sprintf (name
, "__class_%s_t", tname
);
647 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
649 /* Find the top-level namespace. */
650 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
655 ns
= ts
->u
.derived
->ns
;
657 gfc_find_symbol (name
, ns
, 0, &fclass
);
661 /* If not there, create a new symbol. */
662 fclass
= gfc_new_symbol (name
, ns
);
663 st
= gfc_new_symtree (&ns
->sym_root
, name
);
665 gfc_set_sym_referenced (fclass
);
667 fclass
->ts
.type
= BT_UNKNOWN
;
668 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
669 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
670 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
671 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
675 /* Add component '_data'. */
676 if (!gfc_add_component (fclass
, "_data", &c
))
679 c
->ts
.type
= BT_DERIVED
;
680 c
->attr
.access
= ACCESS_PRIVATE
;
681 c
->ts
.u
.derived
= ts
->u
.derived
;
682 c
->attr
.class_pointer
= attr
->pointer
;
683 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
684 || attr
->select_type_temporary
;
685 c
->attr
.allocatable
= attr
->allocatable
;
686 c
->attr
.dimension
= attr
->dimension
;
687 c
->attr
.codimension
= attr
->codimension
;
688 c
->attr
.abstract
= fclass
->attr
.abstract
;
690 c
->initializer
= NULL
;
692 /* Add component '_vptr'. */
693 if (!gfc_add_component (fclass
, "_vptr", &c
))
695 c
->ts
.type
= BT_DERIVED
;
696 c
->attr
.access
= ACCESS_PRIVATE
;
699 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
701 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
703 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
705 /* Add component '_len'. Only unlimited polymorphic pointers may
706 have a string assigned to them, i.e., only those need the _len
708 if (!gfc_add_component (fclass
, "_len", &c
))
710 c
->ts
.type
= BT_INTEGER
;
711 c
->ts
.kind
= gfc_charlen_int_kind
;
712 c
->attr
.access
= ACCESS_PRIVATE
;
713 c
->attr
.artificial
= 1;
716 /* Build vtab later. */
717 c
->ts
.u
.derived
= NULL
;
720 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
722 /* Since the extension field is 8 bit wide, we can only have
723 up to 255 extension levels. */
724 if (ts
->u
.derived
->attr
.extension
== 255)
726 gfc_error ("Maximum extension level reached with type %qs at %L",
727 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
731 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
732 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
733 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
736 fclass
->attr
.is_class
= 1;
737 ts
->u
.derived
= fclass
;
738 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
744 /* Add a procedure pointer component to the vtype
745 to represent a specific type-bound procedure. */
748 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
752 if (tb
->non_overridable
)
755 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
759 /* Add procedure component. */
760 if (!gfc_add_component (vtype
, name
, &c
))
764 c
->tb
= XCNEW (gfc_typebound_proc
);
767 c
->attr
.procedure
= 1;
768 c
->attr
.proc_pointer
= 1;
769 c
->attr
.flavor
= FL_PROCEDURE
;
770 c
->attr
.access
= ACCESS_PRIVATE
;
771 c
->attr
.external
= 1;
773 c
->attr
.if_source
= IFSRC_IFBODY
;
775 else if (c
->attr
.proc_pointer
&& c
->tb
)
783 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
784 c
->ts
.interface
= ifc
;
786 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
787 c
->attr
.pure
= ifc
->attr
.pure
;
792 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
795 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
801 add_procs_to_declared_vtab1 (st
->left
, vtype
);
804 add_procs_to_declared_vtab1 (st
->right
, vtype
);
806 if (st
->n
.tb
&& !st
->n
.tb
->error
807 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
808 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
812 /* Copy procedure pointers components from the parent type. */
815 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
820 vtab
= gfc_find_derived_vtab (declared
);
822 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
824 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
827 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
832 /* Returns true if any of its nonpointer nonallocatable components or
833 their nonpointer nonallocatable subcomponents has a finalization
837 has_finalizer_component (gfc_symbol
*derived
)
841 for (c
= derived
->components
; c
; c
= c
->next
)
843 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
844 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
847 /* Stop infinite recursion through this function by inhibiting
848 calls when the derived type and that of the component are
850 if (c
->ts
.type
== BT_DERIVED
851 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
852 && !c
->attr
.pointer
&& !c
->attr
.allocatable
853 && has_finalizer_component (c
->ts
.u
.derived
))
861 comp_is_finalizable (gfc_component
*comp
)
863 if (comp
->attr
.proc_pointer
)
865 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
867 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
868 && (comp
->ts
.u
.derived
->attr
.alloc_comp
869 || has_finalizer_component (comp
->ts
.u
.derived
)
870 || (comp
->ts
.u
.derived
->f2k_derived
871 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
873 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
874 && CLASS_DATA (comp
)->attr
.allocatable
)
881 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
882 neither allocatable nor a pointer but has a finalizer, call it. If it
883 is a nonpointer component with allocatable components or has finalizers, walk
884 them. Either of them is required; other nonallocatables and pointers aren't
886 Note: If the component is allocatable, the DEALLOCATE handling takes care
887 of calling the appropriate finalizers, coarray deregistering, and
888 deallocation of allocatable subcomponents. */
891 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
892 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
893 gfc_namespace
*sub_ns
)
898 if (!comp_is_finalizable (comp
))
901 e
= gfc_copy_expr (expr
);
903 e
->ref
= ref
= gfc_get_ref ();
906 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
908 ref
->next
= gfc_get_ref ();
911 ref
->type
= REF_COMPONENT
;
912 ref
->u
.c
.sym
= derived
;
913 ref
->u
.c
.component
= comp
;
916 if (comp
->attr
.dimension
|| comp
->attr
.codimension
917 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
918 && (CLASS_DATA (comp
)->attr
.dimension
919 || CLASS_DATA (comp
)->attr
.codimension
)))
921 ref
->next
= gfc_get_ref ();
922 ref
->next
->type
= REF_ARRAY
;
923 ref
->next
->u
.ar
.dimen
= 0;
924 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
926 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
927 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
930 /* Call DEALLOCATE (comp, stat=ignore). */
931 if (comp
->attr
.allocatable
932 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
933 && CLASS_DATA (comp
)->attr
.allocatable
))
935 gfc_code
*dealloc
, *block
= NULL
;
937 /* Add IF (fini_coarray). */
938 if (comp
->attr
.codimension
939 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
940 && CLASS_DATA (comp
)->attr
.codimension
))
942 block
= gfc_get_code (EXEC_IF
);
945 (*code
)->next
= block
;
946 (*code
) = (*code
)->next
;
951 block
->block
= gfc_get_code (EXEC_IF
);
952 block
= block
->block
;
953 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
956 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
958 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
959 dealloc
->ext
.alloc
.list
->expr
= e
;
960 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
962 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
963 cond
->block
= gfc_get_code (EXEC_IF
);
964 cond
->block
->expr1
= gfc_get_expr ();
965 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
966 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
967 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
968 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
969 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
970 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
971 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
972 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
973 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
974 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
975 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
976 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
977 cond
->block
->next
= dealloc
;
983 (*code
)->next
= cond
;
984 (*code
) = (*code
)->next
;
989 else if (comp
->ts
.type
== BT_DERIVED
990 && comp
->ts
.u
.derived
->f2k_derived
991 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
993 /* Call FINAL_WRAPPER (comp); */
994 gfc_code
*final_wrap
;
998 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
999 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1000 if (strcmp (c
->name
, "_final") == 0)
1004 final_wrap
= gfc_get_code (EXEC_CALL
);
1005 final_wrap
->symtree
= c
->initializer
->symtree
;
1006 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1007 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1008 final_wrap
->ext
.actual
->expr
= e
;
1012 (*code
)->next
= final_wrap
;
1013 (*code
) = (*code
)->next
;
1016 (*code
) = final_wrap
;
1022 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1023 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1030 /* Generate code equivalent to
1031 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1032 + offset, c_ptr), ptr). */
1035 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1036 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1039 gfc_expr
*expr
, *expr2
;
1041 /* C_F_POINTER(). */
1042 block
= gfc_get_code (EXEC_CALL
);
1043 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1044 block
->resolved_sym
= block
->symtree
->n
.sym
;
1045 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1046 block
->resolved_sym
->attr
.intrinsic
= 1;
1047 block
->resolved_sym
->attr
.subroutine
= 1;
1048 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1049 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1050 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1051 gfc_commit_symbol (block
->resolved_sym
);
1053 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1054 block
->ext
.actual
= gfc_get_actual_arglist ();
1055 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1056 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1058 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1060 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1062 /* TRANSFER's first argument: C_LOC (array). */
1063 expr
= gfc_get_expr ();
1064 expr
->expr_type
= EXPR_FUNCTION
;
1065 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1066 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1067 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1068 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1069 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1070 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1071 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1072 expr
->value
.function
.actual
->expr
1073 = gfc_lval_expr_from_sym (array
);
1074 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1075 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1076 expr
->ts
.type
= BT_INTEGER
;
1077 expr
->ts
.kind
= gfc_index_integer_kind
;
1080 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1081 gfc_current_locus
, 3, expr
,
1082 gfc_get_int_expr (gfc_index_integer_kind
,
1084 expr2
->ts
.type
= BT_INTEGER
;
1085 expr2
->ts
.kind
= gfc_index_integer_kind
;
1087 /* <array addr> + <offset>. */
1088 block
->ext
.actual
->expr
= gfc_get_expr ();
1089 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1090 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1091 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1092 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1093 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1095 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1096 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1097 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1098 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1104 /* Calculates the offset to the (idx+1)th element of an array, taking the
1105 stride into account. It generates the code:
1108 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1110 offset = offset * byte_stride. */
1113 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1114 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1115 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1116 gfc_code
*block
, gfc_namespace
*sub_ns
)
1119 gfc_expr
*expr
, *expr2
;
1122 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1123 block
= block
->next
;
1124 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1125 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1128 iter
= gfc_get_iterator ();
1129 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1130 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1131 iter
->end
= gfc_copy_expr (rank
);
1132 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1133 block
->next
= gfc_get_code (EXEC_DO
);
1134 block
= block
->next
;
1135 block
->ext
.iterator
= iter
;
1136 block
->block
= gfc_get_code (EXEC_DO
);
1138 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1141 /* mod (idx, sizes(idx2)). */
1142 expr
= gfc_lval_expr_from_sym (sizes
);
1143 expr
->ref
= gfc_get_ref ();
1144 expr
->ref
->type
= REF_ARRAY
;
1145 expr
->ref
->u
.ar
.as
= sizes
->as
;
1146 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1147 expr
->ref
->u
.ar
.dimen
= 1;
1148 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1149 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1151 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1152 gfc_current_locus
, 2,
1153 gfc_lval_expr_from_sym (idx
), expr
);
1156 /* (...) / sizes(idx2-1). */
1157 expr2
= gfc_get_expr ();
1158 expr2
->expr_type
= EXPR_OP
;
1159 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1160 expr2
->value
.op
.op1
= expr
;
1161 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1162 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1163 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1164 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1165 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1166 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1167 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1168 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1169 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1170 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1171 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1172 = gfc_lval_expr_from_sym (idx2
);
1173 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1174 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1175 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1176 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1177 expr2
->ts
= idx
->ts
;
1179 /* ... * strides(idx2). */
1180 expr
= gfc_get_expr ();
1181 expr
->expr_type
= EXPR_OP
;
1182 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1183 expr
->value
.op
.op1
= expr2
;
1184 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1185 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1186 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1187 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1188 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1189 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1190 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1191 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1194 /* offset = offset + ... */
1195 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1196 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1197 block
->block
->next
->expr2
= gfc_get_expr ();
1198 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1199 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1200 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1201 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1202 block
->block
->next
->expr2
->ts
= idx
->ts
;
1204 /* After the loop: offset = offset * byte_stride. */
1205 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1206 block
= block
->next
;
1207 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1208 block
->expr2
= gfc_get_expr ();
1209 block
->expr2
->expr_type
= EXPR_OP
;
1210 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1211 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1212 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1213 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1218 /* Insert code of the following form:
1221 integer(c_intptr_t) :: i
1223 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1224 && (is_contiguous || !final_rank3->attr.contiguous
1225 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1226 || 0 == STORAGE_SIZE (array)) then
1227 call final_rank3 (array)
1230 integer(c_intptr_t) :: offset, j
1231 type(t) :: tmp(shape (array))
1233 do i = 0, size (array)-1
1234 offset = obtain_offset(i, strides, sizes, byte_stride)
1235 addr = transfer (c_loc (array), addr) + offset
1236 call c_f_pointer (transfer (addr, cptr), ptr)
1238 addr = transfer (c_loc (tmp), addr)
1239 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1240 call c_f_pointer (transfer (addr, cptr), ptr2)
1243 call final_rank3 (tmp)
1249 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1250 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1251 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1253 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1254 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1255 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1256 gfc_namespace
*sub_ns
)
1258 gfc_symbol
*tmp_array
, *ptr2
;
1259 gfc_expr
*size_expr
, *offset2
, *expr
;
1265 block
->next
= gfc_get_code (EXEC_IF
);
1266 block
= block
->next
;
1268 block
->block
= gfc_get_code (EXEC_IF
);
1269 block
= block
->block
;
1271 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1272 size_expr
= gfc_get_expr ();
1273 size_expr
->where
= gfc_current_locus
;
1274 size_expr
->expr_type
= EXPR_OP
;
1275 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1277 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1278 size_expr
->value
.op
.op1
1279 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1280 "storage_size", gfc_current_locus
, 2,
1281 gfc_lval_expr_from_sym (array
),
1282 gfc_get_int_expr (gfc_index_integer_kind
,
1285 /* NUMERIC_STORAGE_SIZE. */
1286 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1287 gfc_character_storage_size
);
1288 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1289 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1291 /* IF condition: (stride == size_expr
1292 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1294 || 0 == size_expr. */
1295 block
->expr1
= gfc_get_expr ();
1296 block
->expr1
->ts
.type
= BT_LOGICAL
;
1297 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1298 block
->expr1
->expr_type
= EXPR_OP
;
1299 block
->expr1
->where
= gfc_current_locus
;
1301 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1303 /* byte_stride == size_expr */
1304 expr
= gfc_get_expr ();
1305 expr
->ts
.type
= BT_LOGICAL
;
1306 expr
->ts
.kind
= gfc_default_logical_kind
;
1307 expr
->expr_type
= EXPR_OP
;
1308 expr
->where
= gfc_current_locus
;
1309 expr
->value
.op
.op
= INTRINSIC_EQ
;
1311 = gfc_lval_expr_from_sym (byte_stride
);
1312 expr
->value
.op
.op2
= size_expr
;
1314 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1315 add is_contiguous check. */
1317 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1318 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1321 expr2
= gfc_get_expr ();
1322 expr2
->ts
.type
= BT_LOGICAL
;
1323 expr2
->ts
.kind
= gfc_default_logical_kind
;
1324 expr2
->expr_type
= EXPR_OP
;
1325 expr2
->where
= gfc_current_locus
;
1326 expr2
->value
.op
.op
= INTRINSIC_AND
;
1327 expr2
->value
.op
.op1
= expr
;
1328 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1332 block
->expr1
->value
.op
.op1
= expr
;
1334 /* 0 == size_expr */
1335 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1336 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1337 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1338 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1339 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1340 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1341 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1342 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1343 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1345 /* IF body: call final subroutine. */
1346 block
->next
= gfc_get_code (EXEC_CALL
);
1347 block
->next
->symtree
= fini
->proc_tree
;
1348 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1349 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1350 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1351 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1352 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1356 block
->block
= gfc_get_code (EXEC_IF
);
1357 block
= block
->block
;
1359 /* BLOCK ... END BLOCK. */
1360 block
->next
= gfc_get_code (EXEC_BLOCK
);
1361 block
= block
->next
;
1363 ns
= gfc_build_block_ns (sub_ns
);
1364 block
->ext
.block
.ns
= ns
;
1365 block
->ext
.block
.assoc
= NULL
;
1367 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1368 ptr2
->ts
.type
= BT_DERIVED
;
1369 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1370 ptr2
->attr
.flavor
= FL_VARIABLE
;
1371 ptr2
->attr
.pointer
= 1;
1372 ptr2
->attr
.artificial
= 1;
1373 gfc_set_sym_referenced (ptr2
);
1374 gfc_commit_symbol (ptr2
);
1376 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1377 tmp_array
->ts
.type
= BT_DERIVED
;
1378 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1379 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1380 tmp_array
->attr
.dimension
= 1;
1381 tmp_array
->attr
.artificial
= 1;
1382 tmp_array
->as
= gfc_get_array_spec();
1383 tmp_array
->attr
.intent
= INTENT_INOUT
;
1384 tmp_array
->as
->type
= AS_EXPLICIT
;
1385 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1387 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1389 gfc_expr
*shape_expr
;
1390 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1392 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1394 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1395 gfc_current_locus
, 3,
1396 gfc_lval_expr_from_sym (array
),
1397 gfc_get_int_expr (gfc_default_integer_kind
,
1399 gfc_get_int_expr (gfc_default_integer_kind
,
1401 gfc_index_integer_kind
));
1402 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1403 tmp_array
->as
->upper
[i
] = shape_expr
;
1405 gfc_set_sym_referenced (tmp_array
);
1406 gfc_commit_symbol (tmp_array
);
1409 iter
= gfc_get_iterator ();
1410 iter
->var
= gfc_lval_expr_from_sym (idx
);
1411 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1412 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1413 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1415 block
= gfc_get_code (EXEC_DO
);
1417 block
->ext
.iterator
= iter
;
1418 block
->block
= gfc_get_code (EXEC_DO
);
1420 /* Offset calculation for the new array: idx * size of type (in bytes). */
1421 offset2
= gfc_get_expr ();
1422 offset2
->expr_type
= EXPR_OP
;
1423 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1424 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1425 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1426 offset2
->ts
= byte_stride
->ts
;
1428 /* Offset calculation of "array". */
1429 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1430 byte_stride
, rank
, block
->block
, sub_ns
);
1433 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1434 + idx * stride, c_ptr), ptr). */
1435 block2
->next
= finalization_scalarizer (array
, ptr
,
1436 gfc_lval_expr_from_sym (offset
),
1438 block2
= block2
->next
;
1439 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1440 block2
= block2
->next
;
1443 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1444 block2
= block2
->next
;
1445 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1446 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1448 /* Call now the user's final subroutine. */
1449 block
->next
= gfc_get_code (EXEC_CALL
);
1450 block
= block
->next
;
1451 block
->symtree
= fini
->proc_tree
;
1452 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1453 block
->ext
.actual
= gfc_get_actual_arglist ();
1454 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1456 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1462 iter
= gfc_get_iterator ();
1463 iter
->var
= gfc_lval_expr_from_sym (idx
);
1464 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1465 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1466 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1468 block
->next
= gfc_get_code (EXEC_DO
);
1469 block
= block
->next
;
1470 block
->ext
.iterator
= iter
;
1471 block
->block
= gfc_get_code (EXEC_DO
);
1473 /* Offset calculation of "array". */
1474 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1475 byte_stride
, rank
, block
->block
, sub_ns
);
1478 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1479 + offset, c_ptr), ptr). */
1480 block2
->next
= finalization_scalarizer (array
, ptr
,
1481 gfc_lval_expr_from_sym (offset
),
1483 block2
= block2
->next
;
1484 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1485 gfc_copy_expr (offset2
), sub_ns
);
1486 block2
= block2
->next
;
1489 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1490 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1491 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1495 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1496 derived type "derived". The function first calls the approriate FINAL
1497 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1498 components (but not the inherited ones). Last, it calls the wrapper
1499 subroutine of the parent. The generated wrapper procedure takes as argument
1500 an assumed-rank array.
1501 If neither allocatable components nor FINAL subroutines exists, the vtab
1502 will contain a NULL pointer.
1503 The generated function has the form
1504 _final(assumed-rank array, stride, skip_corarray)
1505 where the array has to be contiguous (except of the lowest dimension). The
1506 stride (in bytes) is used to allow different sizes for ancestor types by
1507 skipping over the additionally added components in the scalarizer. If
1508 "fini_coarray" is false, coarray components are not finalized to allow for
1509 the correct semantic with intrinsic assignment. */
1512 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1513 const char *tname
, gfc_component
*vtab_final
)
1515 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1516 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1517 gfc_component
*comp
;
1518 gfc_namespace
*sub_ns
;
1519 gfc_code
*last_code
, *block
;
1520 char name
[GFC_MAX_SYMBOL_LEN
+1];
1521 bool finalizable_comp
= false;
1522 bool expr_null_wrapper
= false;
1523 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1526 if (derived
->attr
.unlimited_polymorphic
)
1528 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1532 /* Search for the ancestor's finalizers. */
1533 if (derived
->attr
.extension
&& derived
->components
1534 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1535 || has_finalizer_component (derived
)))
1538 gfc_component
*comp
;
1540 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1541 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1542 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1544 ancestor_wrapper
= comp
->initializer
;
1549 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1550 components: Return a NULL() expression; we defer this a bit to have have
1551 an interface declaration. */
1552 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1553 && !derived
->attr
.alloc_comp
1554 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1555 && !has_finalizer_component (derived
))
1556 expr_null_wrapper
= true;
1558 /* Check whether there are new allocatable components. */
1559 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1561 if (comp
== derived
->components
&& derived
->attr
.extension
1562 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1565 finalizable_comp
|= comp_is_finalizable (comp
);
1568 /* If there is no new finalizer and no new allocatable, return with
1569 an expr to the ancestor's one. */
1570 if (!expr_null_wrapper
&& !finalizable_comp
1571 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1573 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1574 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1575 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1576 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1580 /* We now create a wrapper, which does the following:
1581 1. Call the suitable finalization subroutine for this type
1582 2. Loop over all noninherited allocatable components and noninherited
1583 components with allocatable components and DEALLOCATE those; this will
1584 take care of finalizers, coarray deregistering and allocatable
1586 3. Call the ancestor's finalizer. */
1588 /* Declare the wrapper function; it takes an assumed-rank array
1589 and a VALUE logical as arguments. */
1591 /* Set up the namespace. */
1592 sub_ns
= gfc_get_namespace (ns
, 0);
1593 sub_ns
->sibling
= ns
->contained
;
1594 if (!expr_null_wrapper
)
1595 ns
->contained
= sub_ns
;
1596 sub_ns
->resolved
= 1;
1598 /* Set up the procedure symbol. */
1599 sprintf (name
, "__final_%s", tname
);
1600 gfc_get_symbol (name
, sub_ns
, &final
);
1601 sub_ns
->proc_name
= final
;
1602 final
->attr
.flavor
= FL_PROCEDURE
;
1603 final
->attr
.function
= 1;
1604 final
->attr
.pure
= 0;
1605 final
->result
= final
;
1606 final
->ts
.type
= BT_INTEGER
;
1608 final
->attr
.artificial
= 1;
1609 final
->attr
.always_explicit
= 1;
1610 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1611 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1612 final
->module
= ns
->proc_name
->name
;
1613 gfc_set_sym_referenced (final
);
1614 gfc_commit_symbol (final
);
1616 /* Set up formal argument. */
1617 gfc_get_symbol ("array", sub_ns
, &array
);
1618 array
->ts
.type
= BT_DERIVED
;
1619 array
->ts
.u
.derived
= derived
;
1620 array
->attr
.flavor
= FL_VARIABLE
;
1621 array
->attr
.dummy
= 1;
1622 array
->attr
.contiguous
= 1;
1623 array
->attr
.dimension
= 1;
1624 array
->attr
.artificial
= 1;
1625 array
->as
= gfc_get_array_spec();
1626 array
->as
->type
= AS_ASSUMED_RANK
;
1627 array
->as
->rank
= -1;
1628 array
->attr
.intent
= INTENT_INOUT
;
1629 gfc_set_sym_referenced (array
);
1630 final
->formal
= gfc_get_formal_arglist ();
1631 final
->formal
->sym
= array
;
1632 gfc_commit_symbol (array
);
1634 /* Set up formal argument. */
1635 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1636 byte_stride
->ts
.type
= BT_INTEGER
;
1637 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1638 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1639 byte_stride
->attr
.dummy
= 1;
1640 byte_stride
->attr
.value
= 1;
1641 byte_stride
->attr
.artificial
= 1;
1642 gfc_set_sym_referenced (byte_stride
);
1643 final
->formal
->next
= gfc_get_formal_arglist ();
1644 final
->formal
->next
->sym
= byte_stride
;
1645 gfc_commit_symbol (byte_stride
);
1647 /* Set up formal argument. */
1648 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1649 fini_coarray
->ts
.type
= BT_LOGICAL
;
1650 fini_coarray
->ts
.kind
= 1;
1651 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1652 fini_coarray
->attr
.dummy
= 1;
1653 fini_coarray
->attr
.value
= 1;
1654 fini_coarray
->attr
.artificial
= 1;
1655 gfc_set_sym_referenced (fini_coarray
);
1656 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1657 final
->formal
->next
->next
->sym
= fini_coarray
;
1658 gfc_commit_symbol (fini_coarray
);
1660 /* Return with a NULL() expression but with an interface which has
1661 the formal arguments. */
1662 if (expr_null_wrapper
)
1664 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1665 vtab_final
->ts
.interface
= final
;
1669 /* Local variables. */
1671 gfc_get_symbol ("idx", sub_ns
, &idx
);
1672 idx
->ts
.type
= BT_INTEGER
;
1673 idx
->ts
.kind
= gfc_index_integer_kind
;
1674 idx
->attr
.flavor
= FL_VARIABLE
;
1675 idx
->attr
.artificial
= 1;
1676 gfc_set_sym_referenced (idx
);
1677 gfc_commit_symbol (idx
);
1679 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1680 idx2
->ts
.type
= BT_INTEGER
;
1681 idx2
->ts
.kind
= gfc_index_integer_kind
;
1682 idx2
->attr
.flavor
= FL_VARIABLE
;
1683 idx2
->attr
.artificial
= 1;
1684 gfc_set_sym_referenced (idx2
);
1685 gfc_commit_symbol (idx2
);
1687 gfc_get_symbol ("offset", sub_ns
, &offset
);
1688 offset
->ts
.type
= BT_INTEGER
;
1689 offset
->ts
.kind
= gfc_index_integer_kind
;
1690 offset
->attr
.flavor
= FL_VARIABLE
;
1691 offset
->attr
.artificial
= 1;
1692 gfc_set_sym_referenced (offset
);
1693 gfc_commit_symbol (offset
);
1695 /* Create RANK expression. */
1696 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1697 gfc_current_locus
, 1,
1698 gfc_lval_expr_from_sym (array
));
1699 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1700 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1702 /* Create is_contiguous variable. */
1703 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1704 is_contiguous
->ts
.type
= BT_LOGICAL
;
1705 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1706 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1707 is_contiguous
->attr
.artificial
= 1;
1708 gfc_set_sym_referenced (is_contiguous
);
1709 gfc_commit_symbol (is_contiguous
);
1711 /* Create "sizes(0..rank)" variable, which contains the multiplied
1712 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1713 sizes(2) = sizes(1) * extent(dim=2) etc. */
1714 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1715 sizes
->ts
.type
= BT_INTEGER
;
1716 sizes
->ts
.kind
= gfc_index_integer_kind
;
1717 sizes
->attr
.flavor
= FL_VARIABLE
;
1718 sizes
->attr
.dimension
= 1;
1719 sizes
->attr
.artificial
= 1;
1720 sizes
->as
= gfc_get_array_spec();
1721 sizes
->attr
.intent
= INTENT_INOUT
;
1722 sizes
->as
->type
= AS_EXPLICIT
;
1723 sizes
->as
->rank
= 1;
1724 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1725 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1726 gfc_set_sym_referenced (sizes
);
1727 gfc_commit_symbol (sizes
);
1729 /* Create "strides(1..rank)" variable, which contains the strides per
1731 gfc_get_symbol ("strides", sub_ns
, &strides
);
1732 strides
->ts
.type
= BT_INTEGER
;
1733 strides
->ts
.kind
= gfc_index_integer_kind
;
1734 strides
->attr
.flavor
= FL_VARIABLE
;
1735 strides
->attr
.dimension
= 1;
1736 strides
->attr
.artificial
= 1;
1737 strides
->as
= gfc_get_array_spec();
1738 strides
->attr
.intent
= INTENT_INOUT
;
1739 strides
->as
->type
= AS_EXPLICIT
;
1740 strides
->as
->rank
= 1;
1741 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1742 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1743 gfc_set_sym_referenced (strides
);
1744 gfc_commit_symbol (strides
);
1747 /* Set return value to 0. */
1748 last_code
= gfc_get_code (EXEC_ASSIGN
);
1749 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1750 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1751 sub_ns
->code
= last_code
;
1753 /* Set: is_contiguous = .true. */
1754 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1755 last_code
= last_code
->next
;
1756 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1757 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1758 &gfc_current_locus
, true);
1760 /* Set: sizes(0) = 1. */
1761 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1762 last_code
= last_code
->next
;
1763 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1764 last_code
->expr1
->ref
= gfc_get_ref ();
1765 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1766 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1767 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1768 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1769 last_code
->expr1
->ref
->u
.ar
.start
[0]
1770 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1771 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1772 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1776 strides(idx) = _F._stride (array, dim=idx)
1777 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1778 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1782 iter
= gfc_get_iterator ();
1783 iter
->var
= gfc_lval_expr_from_sym (idx
);
1784 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1785 iter
->end
= gfc_copy_expr (rank
);
1786 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1787 last_code
->next
= gfc_get_code (EXEC_DO
);
1788 last_code
= last_code
->next
;
1789 last_code
->ext
.iterator
= iter
;
1790 last_code
->block
= gfc_get_code (EXEC_DO
);
1792 /* strides(idx) = _F._stride(array,dim=idx). */
1793 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1794 block
= last_code
->block
->next
;
1796 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1797 block
->expr1
->ref
= gfc_get_ref ();
1798 block
->expr1
->ref
->type
= REF_ARRAY
;
1799 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1800 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1801 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1802 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1803 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1805 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1806 gfc_current_locus
, 2,
1807 gfc_lval_expr_from_sym (array
),
1808 gfc_lval_expr_from_sym (idx
));
1810 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1811 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1812 block
= block
->next
;
1814 /* sizes(idx) = ... */
1815 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1816 block
->expr1
->ref
= gfc_get_ref ();
1817 block
->expr1
->ref
->type
= REF_ARRAY
;
1818 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1819 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1820 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1821 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1822 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1824 block
->expr2
= gfc_get_expr ();
1825 block
->expr2
->expr_type
= EXPR_OP
;
1826 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1829 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1830 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1831 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1832 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1833 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1834 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1835 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1836 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1837 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1838 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1839 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1840 = gfc_lval_expr_from_sym (idx
);
1841 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1842 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1843 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1844 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1846 /* size(array, dim=idx, kind=index_kind). */
1847 block
->expr2
->value
.op
.op2
1848 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1849 gfc_current_locus
, 3,
1850 gfc_lval_expr_from_sym (array
),
1851 gfc_lval_expr_from_sym (idx
),
1852 gfc_get_int_expr (gfc_index_integer_kind
,
1854 gfc_index_integer_kind
));
1855 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1856 block
->expr2
->ts
= idx
->ts
;
1858 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1859 block
->next
= gfc_get_code (EXEC_IF
);
1860 block
= block
->next
;
1862 block
->block
= gfc_get_code (EXEC_IF
);
1863 block
= block
->block
;
1865 /* if condition: strides(idx) /= sizes(idx-1). */
1866 block
->expr1
= gfc_get_expr ();
1867 block
->expr1
->ts
.type
= BT_LOGICAL
;
1868 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1869 block
->expr1
->expr_type
= EXPR_OP
;
1870 block
->expr1
->where
= gfc_current_locus
;
1871 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1873 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1874 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1875 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1876 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1877 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1878 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1879 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1880 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1882 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1883 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1884 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1885 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1886 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1887 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1888 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1889 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1890 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1891 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1892 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1893 = gfc_lval_expr_from_sym (idx
);
1894 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1895 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1896 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1897 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1899 /* if body: is_contiguous = .false. */
1900 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1901 block
= block
->next
;
1902 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1903 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1904 &gfc_current_locus
, false);
1906 /* Obtain the size (number of elements) of "array" MINUS ONE,
1907 which is used in the scalarization. */
1908 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1909 nelem
->ts
.type
= BT_INTEGER
;
1910 nelem
->ts
.kind
= gfc_index_integer_kind
;
1911 nelem
->attr
.flavor
= FL_VARIABLE
;
1912 nelem
->attr
.artificial
= 1;
1913 gfc_set_sym_referenced (nelem
);
1914 gfc_commit_symbol (nelem
);
1916 /* nelem = sizes (rank) - 1. */
1917 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1918 last_code
= last_code
->next
;
1920 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1922 last_code
->expr2
= gfc_get_expr ();
1923 last_code
->expr2
->expr_type
= EXPR_OP
;
1924 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1925 last_code
->expr2
->value
.op
.op2
1926 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1927 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1929 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1930 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1931 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1932 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1933 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1934 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1935 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1936 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1938 /* Call final subroutines. We now generate code like:
1940 integer, pointer :: ptr
1942 integer(c_intptr_t) :: i, addr
1944 select case (rank (array))
1946 ! If needed, the array is packed
1947 call final_rank3 (array)
1949 do i = 0, size (array)-1
1950 addr = transfer (c_loc (array), addr) + i * stride
1951 call c_f_pointer (transfer (addr, cptr), ptr)
1952 call elemental_final (ptr)
1956 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1958 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1960 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1961 ptr
->ts
.type
= BT_DERIVED
;
1962 ptr
->ts
.u
.derived
= derived
;
1963 ptr
->attr
.flavor
= FL_VARIABLE
;
1964 ptr
->attr
.pointer
= 1;
1965 ptr
->attr
.artificial
= 1;
1966 gfc_set_sym_referenced (ptr
);
1967 gfc_commit_symbol (ptr
);
1969 /* SELECT CASE (RANK (array)). */
1970 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1971 last_code
= last_code
->next
;
1972 last_code
->expr1
= gfc_copy_expr (rank
);
1975 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1977 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1978 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1984 /* CASE (fini_rank). */
1987 block
->block
= gfc_get_code (EXEC_SELECT
);
1988 block
= block
->block
;
1992 block
= gfc_get_code (EXEC_SELECT
);
1993 last_code
->block
= block
;
1995 block
->ext
.block
.case_list
= gfc_get_case ();
1996 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
1997 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
1998 block
->ext
.block
.case_list
->low
1999 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2000 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2002 block
->ext
.block
.case_list
->low
2003 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2004 block
->ext
.block
.case_list
->high
2005 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2007 /* CALL fini_rank (array) - possibly with packing. */
2008 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2009 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2010 idx
, ptr
, nelem
, strides
,
2011 sizes
, idx2
, offset
, is_contiguous
,
2015 block
->next
= gfc_get_code (EXEC_CALL
);
2016 block
->next
->symtree
= fini
->proc_tree
;
2017 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2018 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2019 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2023 /* Elemental call - scalarized. */
2029 block
->block
= gfc_get_code (EXEC_SELECT
);
2030 block
= block
->block
;
2034 block
= gfc_get_code (EXEC_SELECT
);
2035 last_code
->block
= block
;
2037 block
->ext
.block
.case_list
= gfc_get_case ();
2040 iter
= gfc_get_iterator ();
2041 iter
->var
= gfc_lval_expr_from_sym (idx
);
2042 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2043 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2044 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2045 block
->next
= gfc_get_code (EXEC_DO
);
2046 block
= block
->next
;
2047 block
->ext
.iterator
= iter
;
2048 block
->block
= gfc_get_code (EXEC_DO
);
2050 /* Offset calculation. */
2051 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2052 byte_stride
, rank
, block
->block
,
2056 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2057 + offset, c_ptr), ptr). */
2059 = finalization_scalarizer (array
, ptr
,
2060 gfc_lval_expr_from_sym (offset
),
2062 block
= block
->next
;
2064 /* CALL final_elemental (array). */
2065 block
->next
= gfc_get_code (EXEC_CALL
);
2066 block
= block
->next
;
2067 block
->symtree
= fini_elem
->proc_tree
;
2068 block
->resolved_sym
= fini_elem
->proc_sym
;
2069 block
->ext
.actual
= gfc_get_actual_arglist ();
2070 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2074 /* Finalize and deallocate allocatable components. The same manual
2075 scalarization is used as above. */
2077 if (finalizable_comp
)
2080 gfc_code
*block
= NULL
;
2084 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2085 ptr
->ts
.type
= BT_DERIVED
;
2086 ptr
->ts
.u
.derived
= derived
;
2087 ptr
->attr
.flavor
= FL_VARIABLE
;
2088 ptr
->attr
.pointer
= 1;
2089 ptr
->attr
.artificial
= 1;
2090 gfc_set_sym_referenced (ptr
);
2091 gfc_commit_symbol (ptr
);
2094 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2095 stat
->attr
.flavor
= FL_VARIABLE
;
2096 stat
->attr
.artificial
= 1;
2097 stat
->ts
.type
= BT_INTEGER
;
2098 stat
->ts
.kind
= gfc_default_integer_kind
;
2099 gfc_set_sym_referenced (stat
);
2100 gfc_commit_symbol (stat
);
2103 iter
= gfc_get_iterator ();
2104 iter
->var
= gfc_lval_expr_from_sym (idx
);
2105 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2106 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2107 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2108 last_code
->next
= gfc_get_code (EXEC_DO
);
2109 last_code
= last_code
->next
;
2110 last_code
->ext
.iterator
= iter
;
2111 last_code
->block
= gfc_get_code (EXEC_DO
);
2113 /* Offset calculation. */
2114 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2115 byte_stride
, rank
, last_code
->block
,
2119 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2120 + idx * stride, c_ptr), ptr). */
2121 block
->next
= finalization_scalarizer (array
, ptr
,
2122 gfc_lval_expr_from_sym(offset
),
2124 block
= block
->next
;
2126 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2128 if (comp
== derived
->components
&& derived
->attr
.extension
2129 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2132 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2133 stat
, fini_coarray
, &block
, sub_ns
);
2134 if (!last_code
->block
->next
)
2135 last_code
->block
->next
= block
;
2140 /* Call the finalizer of the ancestor. */
2141 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2143 last_code
->next
= gfc_get_code (EXEC_CALL
);
2144 last_code
= last_code
->next
;
2145 last_code
->symtree
= ancestor_wrapper
->symtree
;
2146 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2148 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2149 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2150 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2151 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2152 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2153 last_code
->ext
.actual
->next
->next
->expr
2154 = gfc_lval_expr_from_sym (fini_coarray
);
2157 gfc_free_expr (rank
);
2158 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2159 vtab_final
->ts
.interface
= final
;
2163 /* Add procedure pointers for all type-bound procedures to a vtab. */
2166 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2168 gfc_symbol
* super_type
;
2170 super_type
= gfc_get_derived_super_type (derived
);
2172 if (super_type
&& (super_type
!= derived
))
2174 /* Make sure that the PPCs appear in the same order as in the parent. */
2175 copy_vtab_proc_comps (super_type
, vtype
);
2176 /* Only needed to get the PPC initializers right. */
2177 add_procs_to_declared_vtab (super_type
, vtype
);
2180 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2181 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2183 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2184 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2188 /* Find or generate the symbol for a derived type's vtab. */
2191 gfc_find_derived_vtab (gfc_symbol
*derived
)
2194 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2195 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2196 gfc_gsymbol
*gsym
= NULL
;
2197 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2199 /* Find the top-level namespace. */
2200 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2204 /* If the type is a class container, use the underlying derived type. */
2205 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2206 derived
= gfc_get_derived_super_type (derived
);
2208 /* Find the gsymbol for the module of use associated derived types. */
2209 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2210 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2211 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2215 /* Work in the gsymbol namespace if the top-level namespace is a module.
2216 This ensures that the vtable is unique, which is required since we use
2217 its address in SELECT TYPE. */
2218 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2219 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2224 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2226 get_unique_hashed_string (tname
, derived
);
2227 sprintf (name
, "__vtab_%s", tname
);
2229 /* Look for the vtab symbol in various namespaces. */
2230 if (gsym
&& gsym
->ns
)
2232 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2237 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2239 gfc_find_symbol (name
, ns
, 0, &vtab
);
2241 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2245 gfc_get_symbol (name
, ns
, &vtab
);
2246 vtab
->ts
.type
= BT_DERIVED
;
2247 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2248 &gfc_current_locus
))
2250 vtab
->attr
.target
= 1;
2251 vtab
->attr
.save
= SAVE_IMPLICIT
;
2252 vtab
->attr
.vtab
= 1;
2253 vtab
->attr
.access
= ACCESS_PUBLIC
;
2254 gfc_set_sym_referenced (vtab
);
2255 sprintf (name
, "__vtype_%s", tname
);
2257 gfc_find_symbol (name
, ns
, 0, &vtype
);
2261 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2264 /* Is this a derived type with recursive allocatable
2266 c
= (derived
->attr
.unlimited_polymorphic
2267 || derived
->attr
.abstract
) ?
2268 NULL
: derived
->components
;
2269 for (; c
; c
= c
->next
)
2270 if (c
->ts
.type
== BT_DERIVED
2271 && c
->ts
.u
.derived
== derived
)
2277 gfc_get_symbol (name
, ns
, &vtype
);
2278 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2279 &gfc_current_locus
))
2281 vtype
->attr
.access
= ACCESS_PUBLIC
;
2282 vtype
->attr
.vtype
= 1;
2283 gfc_set_sym_referenced (vtype
);
2285 /* Add component '_hash'. */
2286 if (!gfc_add_component (vtype
, "_hash", &c
))
2288 c
->ts
.type
= BT_INTEGER
;
2290 c
->attr
.access
= ACCESS_PRIVATE
;
2291 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2292 NULL
, derived
->hash_value
);
2294 /* Add component '_size'. */
2295 if (!gfc_add_component (vtype
, "_size", &c
))
2297 c
->ts
.type
= BT_INTEGER
;
2299 c
->attr
.access
= ACCESS_PRIVATE
;
2300 /* Remember the derived type in ts.u.derived,
2301 so that the correct initializer can be set later on
2302 (in gfc_conv_structure). */
2303 c
->ts
.u
.derived
= derived
;
2304 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2307 /* Add component _extends. */
2308 if (!gfc_add_component (vtype
, "_extends", &c
))
2310 c
->attr
.pointer
= 1;
2311 c
->attr
.access
= ACCESS_PRIVATE
;
2312 if (!derived
->attr
.unlimited_polymorphic
)
2313 parent
= gfc_get_derived_super_type (derived
);
2319 parent_vtab
= gfc_find_derived_vtab (parent
);
2320 c
->ts
.type
= BT_DERIVED
;
2321 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2322 c
->initializer
= gfc_get_expr ();
2323 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2324 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2325 0, &c
->initializer
->symtree
);
2329 c
->ts
.type
= BT_DERIVED
;
2330 c
->ts
.u
.derived
= vtype
;
2331 c
->initializer
= gfc_get_null_expr (NULL
);
2334 if (!derived
->attr
.unlimited_polymorphic
2335 && derived
->components
== NULL
2336 && !derived
->attr
.zero_comp
)
2338 /* At this point an error must have occurred.
2339 Prevent further errors on the vtype components. */
2344 /* Add component _def_init. */
2345 if (!gfc_add_component (vtype
, "_def_init", &c
))
2347 c
->attr
.pointer
= 1;
2348 c
->attr
.artificial
= 1;
2349 c
->attr
.access
= ACCESS_PRIVATE
;
2350 c
->ts
.type
= BT_DERIVED
;
2351 c
->ts
.u
.derived
= derived
;
2352 if (derived
->attr
.unlimited_polymorphic
2353 || derived
->attr
.abstract
)
2354 c
->initializer
= gfc_get_null_expr (NULL
);
2357 /* Construct default initialization variable. */
2358 sprintf (name
, "__def_init_%s", tname
);
2359 gfc_get_symbol (name
, ns
, &def_init
);
2360 def_init
->attr
.target
= 1;
2361 def_init
->attr
.artificial
= 1;
2362 def_init
->attr
.save
= SAVE_IMPLICIT
;
2363 def_init
->attr
.access
= ACCESS_PUBLIC
;
2364 def_init
->attr
.flavor
= FL_VARIABLE
;
2365 gfc_set_sym_referenced (def_init
);
2366 def_init
->ts
.type
= BT_DERIVED
;
2367 def_init
->ts
.u
.derived
= derived
;
2368 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2370 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2373 /* Add component _copy. */
2374 if (!gfc_add_component (vtype
, "_copy", &c
))
2376 c
->attr
.proc_pointer
= 1;
2377 c
->attr
.access
= ACCESS_PRIVATE
;
2378 c
->tb
= XCNEW (gfc_typebound_proc
);
2380 if (derived
->attr
.unlimited_polymorphic
2381 || derived
->attr
.abstract
)
2382 c
->initializer
= gfc_get_null_expr (NULL
);
2385 /* Set up namespace. */
2386 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2387 sub_ns
->sibling
= ns
->contained
;
2388 ns
->contained
= sub_ns
;
2389 sub_ns
->resolved
= 1;
2390 /* Set up procedure symbol. */
2391 sprintf (name
, "__copy_%s", tname
);
2392 gfc_get_symbol (name
, sub_ns
, ©
);
2393 sub_ns
->proc_name
= copy
;
2394 copy
->attr
.flavor
= FL_PROCEDURE
;
2395 copy
->attr
.subroutine
= 1;
2396 copy
->attr
.pure
= 1;
2397 copy
->attr
.artificial
= 1;
2398 copy
->attr
.if_source
= IFSRC_DECL
;
2399 /* This is elemental so that arrays are automatically
2400 treated correctly by the scalarizer. */
2401 copy
->attr
.elemental
= 1;
2402 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2403 copy
->module
= ns
->proc_name
->name
;
2404 gfc_set_sym_referenced (copy
);
2405 /* Set up formal arguments. */
2406 gfc_get_symbol ("src", sub_ns
, &src
);
2407 src
->ts
.type
= BT_DERIVED
;
2408 src
->ts
.u
.derived
= derived
;
2409 src
->attr
.flavor
= FL_VARIABLE
;
2410 src
->attr
.dummy
= 1;
2411 src
->attr
.artificial
= 1;
2412 src
->attr
.intent
= INTENT_IN
;
2413 gfc_set_sym_referenced (src
);
2414 copy
->formal
= gfc_get_formal_arglist ();
2415 copy
->formal
->sym
= src
;
2416 gfc_get_symbol ("dst", sub_ns
, &dst
);
2417 dst
->ts
.type
= BT_DERIVED
;
2418 dst
->ts
.u
.derived
= derived
;
2419 dst
->attr
.flavor
= FL_VARIABLE
;
2420 dst
->attr
.dummy
= 1;
2421 dst
->attr
.artificial
= 1;
2422 dst
->attr
.intent
= INTENT_INOUT
;
2423 gfc_set_sym_referenced (dst
);
2424 copy
->formal
->next
= gfc_get_formal_arglist ();
2425 copy
->formal
->next
->sym
= dst
;
2427 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2428 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2429 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2430 /* Set initializer. */
2431 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2432 c
->ts
.interface
= copy
;
2435 /* Add component _final, which contains a procedure pointer to
2436 a wrapper which handles both the freeing of allocatable
2437 components and the calls to finalization subroutines.
2438 Note: The actual wrapper function can only be generated
2439 at resolution time. */
2440 if (!gfc_add_component (vtype
, "_final", &c
))
2442 c
->attr
.proc_pointer
= 1;
2443 c
->attr
.access
= ACCESS_PRIVATE
;
2444 c
->tb
= XCNEW (gfc_typebound_proc
);
2446 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2448 /* Add component _deallocate. */
2449 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2451 c
->attr
.proc_pointer
= 1;
2452 c
->attr
.access
= ACCESS_PRIVATE
;
2453 c
->tb
= XCNEW (gfc_typebound_proc
);
2455 if (derived
->attr
.unlimited_polymorphic
2456 || derived
->attr
.abstract
2458 c
->initializer
= gfc_get_null_expr (NULL
);
2461 /* Set up namespace. */
2462 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2464 sub_ns
->sibling
= ns
->contained
;
2465 ns
->contained
= sub_ns
;
2466 sub_ns
->resolved
= 1;
2467 /* Set up procedure symbol. */
2468 sprintf (name
, "__deallocate_%s", tname
);
2469 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2470 sub_ns
->proc_name
= dealloc
;
2471 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2472 dealloc
->attr
.subroutine
= 1;
2473 dealloc
->attr
.pure
= 1;
2474 dealloc
->attr
.artificial
= 1;
2475 dealloc
->attr
.if_source
= IFSRC_DECL
;
2477 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2478 dealloc
->module
= ns
->proc_name
->name
;
2479 gfc_set_sym_referenced (dealloc
);
2480 /* Set up formal argument. */
2481 gfc_get_symbol ("arg", sub_ns
, &arg
);
2482 arg
->ts
.type
= BT_DERIVED
;
2483 arg
->ts
.u
.derived
= derived
;
2484 arg
->attr
.flavor
= FL_VARIABLE
;
2485 arg
->attr
.dummy
= 1;
2486 arg
->attr
.artificial
= 1;
2487 arg
->attr
.intent
= INTENT_INOUT
;
2488 arg
->attr
.dimension
= 1;
2489 arg
->attr
.allocatable
= 1;
2490 arg
->as
= gfc_get_array_spec();
2491 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2493 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2495 gfc_set_sym_referenced (arg
);
2496 dealloc
->formal
= gfc_get_formal_arglist ();
2497 dealloc
->formal
->sym
= arg
;
2499 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2500 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2501 sub_ns
->code
->ext
.alloc
.list
->expr
2502 = gfc_lval_expr_from_sym (arg
);
2503 /* Set initializer. */
2504 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2505 c
->ts
.interface
= dealloc
;
2508 /* Add procedure pointers for type-bound procedures. */
2509 if (!derived
->attr
.unlimited_polymorphic
)
2510 add_procs_to_declared_vtab (derived
, vtype
);
2514 vtab
->ts
.u
.derived
= vtype
;
2515 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2522 /* It is unexpected to have some symbols added at resolution or code
2523 generation time. We commit the changes in order to keep a clean state. */
2526 gfc_commit_symbol (vtab
);
2528 gfc_commit_symbol (vtype
);
2530 gfc_commit_symbol (def_init
);
2532 gfc_commit_symbol (copy
);
2534 gfc_commit_symbol (src
);
2536 gfc_commit_symbol (dst
);
2538 gfc_commit_symbol (dealloc
);
2540 gfc_commit_symbol (arg
);
2543 gfc_undo_symbols ();
2549 /* Check if a derived type is finalizable. That is the case if it
2550 (1) has a FINAL subroutine or
2551 (2) has a nonpointer nonallocatable component of finalizable type.
2552 If it is finalizable, return an expression containing the
2553 finalization wrapper. */
2556 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2561 /* (1) Check for FINAL subroutines. */
2562 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2565 /* (2) Check for components of finalizable type. */
2566 for (c
= derived
->components
; c
; c
= c
->next
)
2567 if (c
->ts
.type
== BT_DERIVED
2568 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2569 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2575 /* Make sure vtab is generated. */
2576 vtab
= gfc_find_derived_vtab (derived
);
2579 /* Return finalizer expression. */
2580 gfc_component
*final
;
2581 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2582 gcc_assert (strcmp (final
->name
, "_final") == 0);
2583 gcc_assert (final
->initializer
2584 && final
->initializer
->expr_type
!= EXPR_NULL
);
2585 *final_expr
= final
->initializer
;
2591 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2592 needed to support unlimited polymorphism. */
2595 find_intrinsic_vtab (gfc_typespec
*ts
)
2598 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2599 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2601 /* Find the top-level namespace. */
2602 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2608 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2610 /* Encode all types as TYPENAME_KIND_ including especially character
2611 arrays, whose length is now consistently stored in the _len component
2612 of the class-variable. */
2613 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2614 sprintf (name
, "__vtab_%s", tname
);
2616 /* Look for the vtab symbol in the top-level namespace only. */
2617 gfc_find_symbol (name
, ns
, 0, &vtab
);
2621 gfc_get_symbol (name
, ns
, &vtab
);
2622 vtab
->ts
.type
= BT_DERIVED
;
2623 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2624 &gfc_current_locus
))
2626 vtab
->attr
.target
= 1;
2627 vtab
->attr
.save
= SAVE_IMPLICIT
;
2628 vtab
->attr
.vtab
= 1;
2629 vtab
->attr
.access
= ACCESS_PUBLIC
;
2630 gfc_set_sym_referenced (vtab
);
2631 sprintf (name
, "__vtype_%s", tname
);
2633 gfc_find_symbol (name
, ns
, 0, &vtype
);
2638 gfc_namespace
*sub_ns
;
2639 gfc_namespace
*contained
;
2642 gfc_get_symbol (name
, ns
, &vtype
);
2643 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2644 &gfc_current_locus
))
2646 vtype
->attr
.access
= ACCESS_PUBLIC
;
2647 vtype
->attr
.vtype
= 1;
2648 gfc_set_sym_referenced (vtype
);
2650 /* Add component '_hash'. */
2651 if (!gfc_add_component (vtype
, "_hash", &c
))
2653 c
->ts
.type
= BT_INTEGER
;
2655 c
->attr
.access
= ACCESS_PRIVATE
;
2656 hash
= gfc_intrinsic_hash_value (ts
);
2657 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2660 /* Add component '_size'. */
2661 if (!gfc_add_component (vtype
, "_size", &c
))
2663 c
->ts
.type
= BT_INTEGER
;
2665 c
->attr
.access
= ACCESS_PRIVATE
;
2667 /* Build a minimal expression to make use of
2668 target-memory.c/gfc_element_size for 'size'. Special handling
2669 for character arrays, that are not constant sized: to support
2670 len (str) * kind, only the kind information is stored in the
2672 e
= gfc_get_expr ();
2674 e
->expr_type
= EXPR_VARIABLE
;
2675 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2677 ts
->type
== BT_CHARACTER
2679 : (int)gfc_element_size (e
));
2682 /* Add component _extends. */
2683 if (!gfc_add_component (vtype
, "_extends", &c
))
2685 c
->attr
.pointer
= 1;
2686 c
->attr
.access
= ACCESS_PRIVATE
;
2687 c
->ts
.type
= BT_VOID
;
2688 c
->initializer
= gfc_get_null_expr (NULL
);
2690 /* Add component _def_init. */
2691 if (!gfc_add_component (vtype
, "_def_init", &c
))
2693 c
->attr
.pointer
= 1;
2694 c
->attr
.access
= ACCESS_PRIVATE
;
2695 c
->ts
.type
= BT_VOID
;
2696 c
->initializer
= gfc_get_null_expr (NULL
);
2698 /* Add component _copy. */
2699 if (!gfc_add_component (vtype
, "_copy", &c
))
2701 c
->attr
.proc_pointer
= 1;
2702 c
->attr
.access
= ACCESS_PRIVATE
;
2703 c
->tb
= XCNEW (gfc_typebound_proc
);
2706 if (ts
->type
!= BT_CHARACTER
)
2707 sprintf (name
, "__copy_%s", tname
);
2710 /* __copy is always the same for characters.
2711 Check to see if copy function already exists. */
2712 sprintf (name
, "__copy_character_%d", ts
->kind
);
2713 contained
= ns
->contained
;
2714 for (; contained
; contained
= contained
->sibling
)
2715 if (contained
->proc_name
2716 && strcmp (name
, contained
->proc_name
->name
) == 0)
2718 copy
= contained
->proc_name
;
2723 /* Set up namespace. */
2724 sub_ns
= gfc_get_namespace (ns
, 0);
2725 sub_ns
->sibling
= ns
->contained
;
2726 ns
->contained
= sub_ns
;
2727 sub_ns
->resolved
= 1;
2728 /* Set up procedure symbol. */
2729 gfc_get_symbol (name
, sub_ns
, ©
);
2730 sub_ns
->proc_name
= copy
;
2731 copy
->attr
.flavor
= FL_PROCEDURE
;
2732 copy
->attr
.subroutine
= 1;
2733 copy
->attr
.pure
= 1;
2734 copy
->attr
.if_source
= IFSRC_DECL
;
2735 /* This is elemental so that arrays are automatically
2736 treated correctly by the scalarizer. */
2737 copy
->attr
.elemental
= 1;
2738 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2739 copy
->module
= ns
->proc_name
->name
;
2740 gfc_set_sym_referenced (copy
);
2741 /* Set up formal arguments. */
2742 gfc_get_symbol ("src", sub_ns
, &src
);
2743 src
->ts
.type
= ts
->type
;
2744 src
->ts
.kind
= ts
->kind
;
2745 src
->attr
.flavor
= FL_VARIABLE
;
2746 src
->attr
.dummy
= 1;
2747 src
->attr
.intent
= INTENT_IN
;
2748 gfc_set_sym_referenced (src
);
2749 copy
->formal
= gfc_get_formal_arglist ();
2750 copy
->formal
->sym
= src
;
2751 gfc_get_symbol ("dst", sub_ns
, &dst
);
2752 dst
->ts
.type
= ts
->type
;
2753 dst
->ts
.kind
= ts
->kind
;
2754 dst
->attr
.flavor
= FL_VARIABLE
;
2755 dst
->attr
.dummy
= 1;
2756 dst
->attr
.intent
= INTENT_INOUT
;
2757 gfc_set_sym_referenced (dst
);
2758 copy
->formal
->next
= gfc_get_formal_arglist ();
2759 copy
->formal
->next
->sym
= dst
;
2761 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2762 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2763 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2765 /* Set initializer. */
2766 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2767 c
->ts
.interface
= copy
;
2769 /* Add component _final. */
2770 if (!gfc_add_component (vtype
, "_final", &c
))
2772 c
->attr
.proc_pointer
= 1;
2773 c
->attr
.access
= ACCESS_PRIVATE
;
2774 c
->tb
= XCNEW (gfc_typebound_proc
);
2776 c
->initializer
= gfc_get_null_expr (NULL
);
2778 vtab
->ts
.u
.derived
= vtype
;
2779 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2786 /* It is unexpected to have some symbols added at resolution or code
2787 generation time. We commit the changes in order to keep a clean state. */
2790 gfc_commit_symbol (vtab
);
2792 gfc_commit_symbol (vtype
);
2794 gfc_commit_symbol (copy
);
2796 gfc_commit_symbol (src
);
2798 gfc_commit_symbol (dst
);
2801 gfc_undo_symbols ();
2807 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2810 gfc_find_vtab (gfc_typespec
*ts
)
2817 return gfc_find_derived_vtab (ts
->u
.derived
);
2819 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2821 return find_intrinsic_vtab (ts
);
2826 /* General worker function to find either a type-bound procedure or a
2827 type-bound user operator. */
2830 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2831 const char* name
, bool noaccess
, bool uop
,
2837 /* Set default to failure. */
2841 if (derived
->f2k_derived
)
2842 /* Set correct symbol-root. */
2843 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2844 : derived
->f2k_derived
->tb_sym_root
);
2848 /* Try to find it in the current type's namespace. */
2849 res
= gfc_find_symtree (root
, name
);
2850 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2856 if (!noaccess
&& derived
->attr
.use_assoc
2857 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2860 gfc_error ("%qs of %qs is PRIVATE at %L",
2861 name
, derived
->name
, where
);
2869 /* Otherwise, recurse on parent type if derived is an extension. */
2870 if (derived
->attr
.extension
)
2872 gfc_symbol
* super_type
;
2873 super_type
= gfc_get_derived_super_type (derived
);
2874 gcc_assert (super_type
);
2876 return find_typebound_proc_uop (super_type
, t
, name
,
2877 noaccess
, uop
, where
);
2880 /* Nothing found. */
2885 /* Find a type-bound procedure or user operator by name for a derived-type
2886 (looking recursively through the super-types). */
2889 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2890 const char* name
, bool noaccess
, locus
* where
)
2892 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2896 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2897 const char* name
, bool noaccess
, locus
* where
)
2899 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2903 /* Find a type-bound intrinsic operator looking recursively through the
2904 super-type hierarchy. */
2907 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2908 gfc_intrinsic_op op
, bool noaccess
,
2911 gfc_typebound_proc
* res
;
2913 /* Set default to failure. */
2917 /* Try to find it in the current type's namespace. */
2918 if (derived
->f2k_derived
)
2919 res
= derived
->f2k_derived
->tb_op
[op
];
2924 if (res
&& !res
->error
)
2930 if (!noaccess
&& derived
->attr
.use_assoc
2931 && res
->access
== ACCESS_PRIVATE
)
2934 gfc_error ("%qs of %qs is PRIVATE at %L",
2935 gfc_op2string (op
), derived
->name
, where
);
2943 /* Otherwise, recurse on parent type if derived is an extension. */
2944 if (derived
->attr
.extension
)
2946 gfc_symbol
* super_type
;
2947 super_type
= gfc_get_derived_super_type (derived
);
2948 gcc_assert (super_type
);
2950 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2954 /* Nothing found. */
2959 /* Get a typebound-procedure symtree or create and insert it if not yet
2960 present. This is like a very simplified version of gfc_get_sym_tree for
2961 tbp-symtrees rather than regular ones. */
2964 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2966 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
2967 return result
? result
: gfc_new_symtree (root
, name
);