1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2017 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
->u
.ar
.type
!= AR_ELEMENT
)
317 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
321 return no_data
|| with_data
;
325 /* Returns true if the expression contains a reference to a class
326 array. Notice that class array elements return false. */
329 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
339 /* Is this a class array object? ie. Is the symbol of type class? */
341 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
342 && CLASS_DATA (e
->symtree
->n
.sym
)
343 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
344 && class_array_ref_detected (e
->ref
, full_array
))
347 /* Or is this a class array component reference? */
348 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
350 if (ref
->type
== REF_COMPONENT
351 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
352 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
353 && class_array_ref_detected (ref
->next
, full_array
))
361 /* Returns true if the expression is a reference to a class
362 scalar. This function is necessary because such expressions
363 can be dressed with a reference to the _data component and so
364 have a type other than BT_CLASS. */
367 gfc_is_class_scalar_expr (gfc_expr
*e
)
374 /* Is this a class object? */
376 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
377 && CLASS_DATA (e
->symtree
->n
.sym
)
378 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
380 || (e
->ref
->type
== REF_COMPONENT
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 || (ref
->next
->type
== REF_COMPONENT
394 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
395 && ref
->next
->next
== NULL
)))
403 /* Tells whether the expression E is a reference to a (scalar) class container.
404 Scalar because array class containers usually have an array reference after
405 them, and gfc_fix_class_refs will add the missing "_data" component reference
409 gfc_is_class_container_ref (gfc_expr
*e
)
414 if (e
->expr_type
!= EXPR_VARIABLE
)
415 return e
->ts
.type
== BT_CLASS
;
417 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
422 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
424 if (ref
->type
!= REF_COMPONENT
)
426 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
436 /* Build an initializer for CLASS pointers,
437 initializing the _data component to the init_expr (or NULL) and the _vptr
438 component to the corresponding type (or the declared type, given by ts). */
441 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
445 gfc_symbol
*vtab
= NULL
;
447 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
448 vtab
= gfc_find_vtab (&init_expr
->ts
);
450 vtab
= gfc_find_vtab (ts
);
452 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
453 &ts
->u
.derived
->declared_at
);
456 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
458 gfc_constructor
*ctor
= gfc_constructor_get();
459 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
460 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
461 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
462 ctor
->expr
= gfc_copy_expr (init_expr
);
464 ctor
->expr
= gfc_get_null_expr (NULL
);
465 gfc_constructor_append (&init
->value
.constructor
, ctor
);
472 /* Create a unique string identifier for a derived type, composed of its name
473 and module name. This is used to construct unique names for the class
474 containers and vtab symbols. */
477 get_unique_type_string (char *string
, gfc_symbol
*derived
)
479 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
480 if (derived
->attr
.unlimited_polymorphic
)
481 strcpy (dt_name
, "STAR");
483 strcpy (dt_name
, gfc_dt_upper_string (derived
->name
));
484 if (derived
->attr
.unlimited_polymorphic
)
485 sprintf (string
, "_%s", dt_name
);
486 else if (derived
->module
)
487 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
488 else if (derived
->ns
->proc_name
)
489 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
491 sprintf (string
, "_%s", dt_name
);
495 /* A relative of 'get_unique_type_string' which makes sure the generated
496 string will not be too long (replacing it by a hash string if needed). */
499 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
501 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
502 get_unique_type_string (&tmp
[0], derived
);
503 /* If string is too long, use hash value in hex representation (allow for
504 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
505 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
506 where %d is the (co)rank which can be up to n = 15. */
507 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
509 int h
= gfc_hash_value (derived
);
510 sprintf (string
, "%X", h
);
513 strcpy (string
, tmp
);
517 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
520 gfc_hash_value (gfc_symbol
*sym
)
522 unsigned int hash
= 0;
523 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
526 get_unique_type_string (&c
[0], sym
);
529 for (i
= 0; i
< len
; i
++)
530 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
532 /* Return the hash but take the modulus for the sake of module read,
533 even though this slightly increases the chance of collision. */
534 return (hash
% 100000000);
538 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
541 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
543 unsigned int hash
= 0;
544 const char *c
= gfc_typename (ts
);
549 for (i
= 0; i
< len
; i
++)
550 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
552 /* Return the hash but take the modulus for the sake of module read,
553 even though this slightly increases the chance of collision. */
554 return (hash
% 100000000);
558 /* Get the _len component from a class/derived object storing a string.
559 For unlimited polymorphic entities a ref to the _data component is available
560 while a ref to the _len component is needed. This routine traverese the
561 ref-chain and strips the last ref to a _data from it replacing it with a
562 ref to the _len component. */
565 gfc_get_len_component (gfc_expr
*e
)
568 gfc_ref
*ref
, **last
;
570 ptr
= gfc_copy_expr (e
);
572 /* We need to remove the last _data component ref from ptr. */
578 && ref
->type
== REF_COMPONENT
579 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
581 gfc_free_ref_list (ref
);
588 /* And replace if with a ref to the _len component. */
589 gfc_add_len_component (ptr
);
594 /* Build a polymorphic CLASS entity, using the symbol that comes from
595 build_sym. A CLASS entity is represented by an encapsulating type,
596 which contains the declared type as '_data' component, plus a pointer
597 component '_vptr' which determines the dynamic type. When this CLASS
598 entity is unlimited polymorphic, then also add a component '_len' to
599 store the length of string when that is stored in it. */
602 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
605 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
614 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
616 gfc_error ("Assumed size polymorphic objects or components, such "
617 "as that at %C, have not yet been implemented");
622 /* Class container has already been built. */
625 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
626 || attr
->select_type_temporary
|| attr
->associate_var
;
629 /* We can not build the class container yet. */
632 /* Determine the name of the encapsulating type. */
633 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
634 get_unique_hashed_string (tname
, ts
->u
.derived
);
635 if ((*as
) && attr
->allocatable
)
636 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
637 else if ((*as
) && attr
->pointer
)
638 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
640 sprintf (name
, "__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
641 else if (attr
->pointer
)
642 sprintf (name
, "__class_%s_p", tname
);
643 else if (attr
->allocatable
)
644 sprintf (name
, "__class_%s_a", tname
);
646 sprintf (name
, "__class_%s_t", tname
);
648 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
650 /* Find the top-level namespace. */
651 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
656 ns
= ts
->u
.derived
->ns
;
658 gfc_find_symbol (name
, ns
, 0, &fclass
);
662 /* If not there, create a new symbol. */
663 fclass
= gfc_new_symbol (name
, ns
);
664 st
= gfc_new_symtree (&ns
->sym_root
, name
);
666 gfc_set_sym_referenced (fclass
);
668 fclass
->ts
.type
= BT_UNKNOWN
;
669 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
670 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
671 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
672 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
676 /* Add component '_data'. */
677 if (!gfc_add_component (fclass
, "_data", &c
))
680 c
->ts
.type
= BT_DERIVED
;
681 c
->attr
.access
= ACCESS_PRIVATE
;
682 c
->ts
.u
.derived
= ts
->u
.derived
;
683 c
->attr
.class_pointer
= attr
->pointer
;
684 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
685 || attr
->select_type_temporary
;
686 c
->attr
.allocatable
= attr
->allocatable
;
687 c
->attr
.dimension
= attr
->dimension
;
688 c
->attr
.codimension
= attr
->codimension
;
689 c
->attr
.abstract
= fclass
->attr
.abstract
;
691 c
->initializer
= NULL
;
693 /* Add component '_vptr'. */
694 if (!gfc_add_component (fclass
, "_vptr", &c
))
696 c
->ts
.type
= BT_DERIVED
;
697 c
->attr
.access
= ACCESS_PRIVATE
;
700 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
702 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
704 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
706 /* Add component '_len'. Only unlimited polymorphic pointers may
707 have a string assigned to them, i.e., only those need the _len
709 if (!gfc_add_component (fclass
, "_len", &c
))
711 c
->ts
.type
= BT_INTEGER
;
712 c
->ts
.kind
= gfc_charlen_int_kind
;
713 c
->attr
.access
= ACCESS_PRIVATE
;
714 c
->attr
.artificial
= 1;
717 /* Build vtab later. */
718 c
->ts
.u
.derived
= NULL
;
721 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
723 /* Since the extension field is 8 bit wide, we can only have
724 up to 255 extension levels. */
725 if (ts
->u
.derived
->attr
.extension
== 255)
727 gfc_error ("Maximum extension level reached with type %qs at %L",
728 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
732 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
733 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
734 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
737 fclass
->attr
.is_class
= 1;
738 ts
->u
.derived
= fclass
;
739 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
745 /* Add a procedure pointer component to the vtype
746 to represent a specific type-bound procedure. */
749 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
753 if (tb
->non_overridable
&& !tb
->overridden
)
756 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
760 /* Add procedure component. */
761 if (!gfc_add_component (vtype
, name
, &c
))
765 c
->tb
= XCNEW (gfc_typebound_proc
);
768 c
->attr
.procedure
= 1;
769 c
->attr
.proc_pointer
= 1;
770 c
->attr
.flavor
= FL_PROCEDURE
;
771 c
->attr
.access
= ACCESS_PRIVATE
;
772 c
->attr
.external
= 1;
774 c
->attr
.if_source
= IFSRC_IFBODY
;
776 else if (c
->attr
.proc_pointer
&& c
->tb
)
784 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
785 c
->ts
.interface
= ifc
;
787 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
788 c
->attr
.pure
= ifc
->attr
.pure
;
793 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
796 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
802 add_procs_to_declared_vtab1 (st
->left
, vtype
);
805 add_procs_to_declared_vtab1 (st
->right
, vtype
);
807 if (st
->n
.tb
&& !st
->n
.tb
->error
808 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
809 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
813 /* Copy procedure pointers components from the parent type. */
816 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
821 vtab
= gfc_find_derived_vtab (declared
);
823 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
825 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
828 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
833 /* Returns true if any of its nonpointer nonallocatable components or
834 their nonpointer nonallocatable subcomponents has a finalization
838 has_finalizer_component (gfc_symbol
*derived
)
842 for (c
= derived
->components
; c
; c
= c
->next
)
843 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
)
845 if (c
->ts
.u
.derived
->f2k_derived
846 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
849 /* Stop infinite recursion through this function by inhibiting
850 calls when the derived type and that of the component are
852 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
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 cond
->block
->expr1
->where
= gfc_current_locus
;
967 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
968 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
969 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
970 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
971 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
972 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
973 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
974 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
975 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
976 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
977 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
978 cond
->block
->next
= dealloc
;
984 (*code
)->next
= cond
;
985 (*code
) = (*code
)->next
;
990 else if (comp
->ts
.type
== BT_DERIVED
991 && comp
->ts
.u
.derived
->f2k_derived
992 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
994 /* Call FINAL_WRAPPER (comp); */
995 gfc_code
*final_wrap
;
999 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1000 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1001 if (strcmp (c
->name
, "_final") == 0)
1005 final_wrap
= gfc_get_code (EXEC_CALL
);
1006 final_wrap
->symtree
= c
->initializer
->symtree
;
1007 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1008 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1009 final_wrap
->ext
.actual
->expr
= e
;
1013 (*code
)->next
= final_wrap
;
1014 (*code
) = (*code
)->next
;
1017 (*code
) = final_wrap
;
1023 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1024 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1031 /* Generate code equivalent to
1032 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1033 + offset, c_ptr), ptr). */
1036 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1037 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1040 gfc_expr
*expr
, *expr2
;
1042 /* C_F_POINTER(). */
1043 block
= gfc_get_code (EXEC_CALL
);
1044 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1045 block
->resolved_sym
= block
->symtree
->n
.sym
;
1046 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1047 block
->resolved_sym
->attr
.intrinsic
= 1;
1048 block
->resolved_sym
->attr
.subroutine
= 1;
1049 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1050 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1051 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1052 gfc_commit_symbol (block
->resolved_sym
);
1054 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1055 block
->ext
.actual
= gfc_get_actual_arglist ();
1056 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1057 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1059 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1061 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1063 /* TRANSFER's first argument: C_LOC (array). */
1064 expr
= gfc_get_expr ();
1065 expr
->expr_type
= EXPR_FUNCTION
;
1066 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1067 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1068 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1069 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1070 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1071 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1072 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1073 expr
->value
.function
.actual
->expr
1074 = gfc_lval_expr_from_sym (array
);
1075 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1076 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1077 expr
->ts
.type
= BT_INTEGER
;
1078 expr
->ts
.kind
= gfc_index_integer_kind
;
1079 expr
->where
= gfc_current_locus
;
1082 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1083 gfc_current_locus
, 3, expr
,
1084 gfc_get_int_expr (gfc_index_integer_kind
,
1086 expr2
->ts
.type
= BT_INTEGER
;
1087 expr2
->ts
.kind
= gfc_index_integer_kind
;
1089 /* <array addr> + <offset>. */
1090 block
->ext
.actual
->expr
= gfc_get_expr ();
1091 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1092 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1093 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1094 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1095 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1096 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1098 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1099 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1100 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1101 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1107 /* Calculates the offset to the (idx+1)th element of an array, taking the
1108 stride into account. It generates the code:
1111 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1113 offset = offset * byte_stride. */
1116 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1117 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1118 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1119 gfc_code
*block
, gfc_namespace
*sub_ns
)
1122 gfc_expr
*expr
, *expr2
;
1125 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1126 block
= block
->next
;
1127 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1128 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1131 iter
= gfc_get_iterator ();
1132 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1133 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1134 iter
->end
= gfc_copy_expr (rank
);
1135 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1136 block
->next
= gfc_get_code (EXEC_DO
);
1137 block
= block
->next
;
1138 block
->ext
.iterator
= iter
;
1139 block
->block
= gfc_get_code (EXEC_DO
);
1141 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1144 /* mod (idx, sizes(idx2)). */
1145 expr
= gfc_lval_expr_from_sym (sizes
);
1146 expr
->ref
= gfc_get_ref ();
1147 expr
->ref
->type
= REF_ARRAY
;
1148 expr
->ref
->u
.ar
.as
= sizes
->as
;
1149 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1150 expr
->ref
->u
.ar
.dimen
= 1;
1151 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1152 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1153 expr
->where
= sizes
->declared_at
;
1155 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1156 gfc_current_locus
, 2,
1157 gfc_lval_expr_from_sym (idx
), expr
);
1160 /* (...) / sizes(idx2-1). */
1161 expr2
= gfc_get_expr ();
1162 expr2
->expr_type
= EXPR_OP
;
1163 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1164 expr2
->value
.op
.op1
= expr
;
1165 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1166 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1167 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1168 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1169 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1170 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1171 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1172 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1173 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1174 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1175 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1176 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1177 = gfc_lval_expr_from_sym (idx2
);
1178 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1179 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1180 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1181 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1182 expr2
->ts
= idx
->ts
;
1183 expr2
->where
= gfc_current_locus
;
1185 /* ... * strides(idx2). */
1186 expr
= gfc_get_expr ();
1187 expr
->expr_type
= EXPR_OP
;
1188 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1189 expr
->value
.op
.op1
= expr2
;
1190 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1191 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1192 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1193 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1194 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1195 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1196 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1197 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1199 expr
->where
= gfc_current_locus
;
1201 /* offset = offset + ... */
1202 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1203 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1204 block
->block
->next
->expr2
= gfc_get_expr ();
1205 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1206 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1207 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1208 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1209 block
->block
->next
->expr2
->ts
= idx
->ts
;
1210 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1212 /* After the loop: offset = offset * byte_stride. */
1213 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1214 block
= block
->next
;
1215 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1216 block
->expr2
= gfc_get_expr ();
1217 block
->expr2
->expr_type
= EXPR_OP
;
1218 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1219 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1220 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1221 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1222 block
->expr2
->where
= gfc_current_locus
;
1227 /* Insert code of the following form:
1230 integer(c_intptr_t) :: i
1232 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1233 && (is_contiguous || !final_rank3->attr.contiguous
1234 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1235 || 0 == STORAGE_SIZE (array)) then
1236 call final_rank3 (array)
1239 integer(c_intptr_t) :: offset, j
1240 type(t) :: tmp(shape (array))
1242 do i = 0, size (array)-1
1243 offset = obtain_offset(i, strides, sizes, byte_stride)
1244 addr = transfer (c_loc (array), addr) + offset
1245 call c_f_pointer (transfer (addr, cptr), ptr)
1247 addr = transfer (c_loc (tmp), addr)
1248 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1249 call c_f_pointer (transfer (addr, cptr), ptr2)
1252 call final_rank3 (tmp)
1258 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1259 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1260 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1262 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1263 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1264 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1265 gfc_namespace
*sub_ns
)
1267 gfc_symbol
*tmp_array
, *ptr2
;
1268 gfc_expr
*size_expr
, *offset2
, *expr
;
1274 block
->next
= gfc_get_code (EXEC_IF
);
1275 block
= block
->next
;
1277 block
->block
= gfc_get_code (EXEC_IF
);
1278 block
= block
->block
;
1280 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1281 size_expr
= gfc_get_expr ();
1282 size_expr
->where
= gfc_current_locus
;
1283 size_expr
->expr_type
= EXPR_OP
;
1284 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1286 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1287 size_expr
->value
.op
.op1
1288 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1289 "storage_size", gfc_current_locus
, 2,
1290 gfc_lval_expr_from_sym (array
),
1291 gfc_get_int_expr (gfc_index_integer_kind
,
1294 /* NUMERIC_STORAGE_SIZE. */
1295 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1296 gfc_character_storage_size
);
1297 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1298 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1300 /* IF condition: (stride == size_expr
1301 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1303 || 0 == size_expr. */
1304 block
->expr1
= gfc_get_expr ();
1305 block
->expr1
->ts
.type
= BT_LOGICAL
;
1306 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1307 block
->expr1
->expr_type
= EXPR_OP
;
1308 block
->expr1
->where
= gfc_current_locus
;
1310 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1312 /* byte_stride == size_expr */
1313 expr
= gfc_get_expr ();
1314 expr
->ts
.type
= BT_LOGICAL
;
1315 expr
->ts
.kind
= gfc_default_logical_kind
;
1316 expr
->expr_type
= EXPR_OP
;
1317 expr
->where
= gfc_current_locus
;
1318 expr
->value
.op
.op
= INTRINSIC_EQ
;
1320 = gfc_lval_expr_from_sym (byte_stride
);
1321 expr
->value
.op
.op2
= size_expr
;
1323 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1324 add is_contiguous check. */
1326 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1327 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1330 expr2
= gfc_get_expr ();
1331 expr2
->ts
.type
= BT_LOGICAL
;
1332 expr2
->ts
.kind
= gfc_default_logical_kind
;
1333 expr2
->expr_type
= EXPR_OP
;
1334 expr2
->where
= gfc_current_locus
;
1335 expr2
->value
.op
.op
= INTRINSIC_AND
;
1336 expr2
->value
.op
.op1
= expr
;
1337 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1341 block
->expr1
->value
.op
.op1
= expr
;
1343 /* 0 == size_expr */
1344 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1345 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1346 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1347 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1348 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1349 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1350 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1351 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1352 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1354 /* IF body: call final subroutine. */
1355 block
->next
= gfc_get_code (EXEC_CALL
);
1356 block
->next
->symtree
= fini
->proc_tree
;
1357 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1358 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1359 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1360 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1361 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1365 block
->block
= gfc_get_code (EXEC_IF
);
1366 block
= block
->block
;
1368 /* BLOCK ... END BLOCK. */
1369 block
->next
= gfc_get_code (EXEC_BLOCK
);
1370 block
= block
->next
;
1372 ns
= gfc_build_block_ns (sub_ns
);
1373 block
->ext
.block
.ns
= ns
;
1374 block
->ext
.block
.assoc
= NULL
;
1376 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1377 ptr2
->ts
.type
= BT_DERIVED
;
1378 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1379 ptr2
->attr
.flavor
= FL_VARIABLE
;
1380 ptr2
->attr
.pointer
= 1;
1381 ptr2
->attr
.artificial
= 1;
1382 gfc_set_sym_referenced (ptr2
);
1383 gfc_commit_symbol (ptr2
);
1385 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1386 tmp_array
->ts
.type
= BT_DERIVED
;
1387 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1388 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1389 tmp_array
->attr
.dimension
= 1;
1390 tmp_array
->attr
.artificial
= 1;
1391 tmp_array
->as
= gfc_get_array_spec();
1392 tmp_array
->attr
.intent
= INTENT_INOUT
;
1393 tmp_array
->as
->type
= AS_EXPLICIT
;
1394 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1396 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1398 gfc_expr
*shape_expr
;
1399 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1401 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1403 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1404 gfc_current_locus
, 3,
1405 gfc_lval_expr_from_sym (array
),
1406 gfc_get_int_expr (gfc_default_integer_kind
,
1408 gfc_get_int_expr (gfc_default_integer_kind
,
1410 gfc_index_integer_kind
));
1411 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1412 tmp_array
->as
->upper
[i
] = shape_expr
;
1414 gfc_set_sym_referenced (tmp_array
);
1415 gfc_commit_symbol (tmp_array
);
1418 iter
= gfc_get_iterator ();
1419 iter
->var
= gfc_lval_expr_from_sym (idx
);
1420 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1421 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1422 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1424 block
= gfc_get_code (EXEC_DO
);
1426 block
->ext
.iterator
= iter
;
1427 block
->block
= gfc_get_code (EXEC_DO
);
1429 /* Offset calculation for the new array: idx * size of type (in bytes). */
1430 offset2
= gfc_get_expr ();
1431 offset2
->expr_type
= EXPR_OP
;
1432 offset2
->where
= gfc_current_locus
;
1433 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1434 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1435 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1436 offset2
->ts
= byte_stride
->ts
;
1438 /* Offset calculation of "array". */
1439 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1440 byte_stride
, rank
, block
->block
, sub_ns
);
1443 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1444 + idx * stride, c_ptr), ptr). */
1445 block2
->next
= finalization_scalarizer (array
, ptr
,
1446 gfc_lval_expr_from_sym (offset
),
1448 block2
= block2
->next
;
1449 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1450 block2
= block2
->next
;
1453 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1454 block2
= block2
->next
;
1455 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1456 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1458 /* Call now the user's final subroutine. */
1459 block
->next
= gfc_get_code (EXEC_CALL
);
1460 block
= block
->next
;
1461 block
->symtree
= fini
->proc_tree
;
1462 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1463 block
->ext
.actual
= gfc_get_actual_arglist ();
1464 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1466 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1472 iter
= gfc_get_iterator ();
1473 iter
->var
= gfc_lval_expr_from_sym (idx
);
1474 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1475 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1476 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1478 block
->next
= gfc_get_code (EXEC_DO
);
1479 block
= block
->next
;
1480 block
->ext
.iterator
= iter
;
1481 block
->block
= gfc_get_code (EXEC_DO
);
1483 /* Offset calculation of "array". */
1484 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1485 byte_stride
, rank
, block
->block
, sub_ns
);
1488 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1489 + offset, c_ptr), ptr). */
1490 block2
->next
= finalization_scalarizer (array
, ptr
,
1491 gfc_lval_expr_from_sym (offset
),
1493 block2
= block2
->next
;
1494 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1495 gfc_copy_expr (offset2
), sub_ns
);
1496 block2
= block2
->next
;
1499 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1500 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1501 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1505 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1506 derived type "derived". The function first calls the approriate FINAL
1507 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1508 components (but not the inherited ones). Last, it calls the wrapper
1509 subroutine of the parent. The generated wrapper procedure takes as argument
1510 an assumed-rank array.
1511 If neither allocatable components nor FINAL subroutines exists, the vtab
1512 will contain a NULL pointer.
1513 The generated function has the form
1514 _final(assumed-rank array, stride, skip_corarray)
1515 where the array has to be contiguous (except of the lowest dimension). The
1516 stride (in bytes) is used to allow different sizes for ancestor types by
1517 skipping over the additionally added components in the scalarizer. If
1518 "fini_coarray" is false, coarray components are not finalized to allow for
1519 the correct semantic with intrinsic assignment. */
1522 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1523 const char *tname
, gfc_component
*vtab_final
)
1525 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1526 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1527 gfc_component
*comp
;
1528 gfc_namespace
*sub_ns
;
1529 gfc_code
*last_code
, *block
;
1530 char name
[GFC_MAX_SYMBOL_LEN
+1];
1531 bool finalizable_comp
= false;
1532 bool expr_null_wrapper
= false;
1533 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1536 if (derived
->attr
.unlimited_polymorphic
)
1538 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1542 /* Search for the ancestor's finalizers. */
1543 if (derived
->attr
.extension
&& derived
->components
1544 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1545 || has_finalizer_component (derived
)))
1548 gfc_component
*comp
;
1550 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1551 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1552 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1554 ancestor_wrapper
= comp
->initializer
;
1559 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1560 components: Return a NULL() expression; we defer this a bit to have have
1561 an interface declaration. */
1562 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1563 && !derived
->attr
.alloc_comp
1564 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1565 && !has_finalizer_component (derived
))
1566 expr_null_wrapper
= true;
1568 /* Check whether there are new allocatable components. */
1569 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1571 if (comp
== derived
->components
&& derived
->attr
.extension
1572 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1575 finalizable_comp
|= comp_is_finalizable (comp
);
1578 /* If there is no new finalizer and no new allocatable, return with
1579 an expr to the ancestor's one. */
1580 if (!expr_null_wrapper
&& !finalizable_comp
1581 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1583 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1584 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1585 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1586 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1590 /* We now create a wrapper, which does the following:
1591 1. Call the suitable finalization subroutine for this type
1592 2. Loop over all noninherited allocatable components and noninherited
1593 components with allocatable components and DEALLOCATE those; this will
1594 take care of finalizers, coarray deregistering and allocatable
1596 3. Call the ancestor's finalizer. */
1598 /* Declare the wrapper function; it takes an assumed-rank array
1599 and a VALUE logical as arguments. */
1601 /* Set up the namespace. */
1602 sub_ns
= gfc_get_namespace (ns
, 0);
1603 sub_ns
->sibling
= ns
->contained
;
1604 if (!expr_null_wrapper
)
1605 ns
->contained
= sub_ns
;
1606 sub_ns
->resolved
= 1;
1608 /* Set up the procedure symbol. */
1609 sprintf (name
, "__final_%s", tname
);
1610 gfc_get_symbol (name
, sub_ns
, &final
);
1611 sub_ns
->proc_name
= final
;
1612 final
->attr
.flavor
= FL_PROCEDURE
;
1613 final
->attr
.function
= 1;
1614 final
->attr
.pure
= 0;
1615 final
->attr
.recursive
= 1;
1616 final
->result
= final
;
1617 final
->ts
.type
= BT_INTEGER
;
1619 final
->attr
.artificial
= 1;
1620 final
->attr
.always_explicit
= 1;
1621 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1622 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1623 final
->module
= ns
->proc_name
->name
;
1624 gfc_set_sym_referenced (final
);
1625 gfc_commit_symbol (final
);
1627 /* Set up formal argument. */
1628 gfc_get_symbol ("array", sub_ns
, &array
);
1629 array
->ts
.type
= BT_DERIVED
;
1630 array
->ts
.u
.derived
= derived
;
1631 array
->attr
.flavor
= FL_VARIABLE
;
1632 array
->attr
.dummy
= 1;
1633 array
->attr
.contiguous
= 1;
1634 array
->attr
.dimension
= 1;
1635 array
->attr
.artificial
= 1;
1636 array
->as
= gfc_get_array_spec();
1637 array
->as
->type
= AS_ASSUMED_RANK
;
1638 array
->as
->rank
= -1;
1639 array
->attr
.intent
= INTENT_INOUT
;
1640 gfc_set_sym_referenced (array
);
1641 final
->formal
= gfc_get_formal_arglist ();
1642 final
->formal
->sym
= array
;
1643 gfc_commit_symbol (array
);
1645 /* Set up formal argument. */
1646 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1647 byte_stride
->ts
.type
= BT_INTEGER
;
1648 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1649 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1650 byte_stride
->attr
.dummy
= 1;
1651 byte_stride
->attr
.value
= 1;
1652 byte_stride
->attr
.artificial
= 1;
1653 gfc_set_sym_referenced (byte_stride
);
1654 final
->formal
->next
= gfc_get_formal_arglist ();
1655 final
->formal
->next
->sym
= byte_stride
;
1656 gfc_commit_symbol (byte_stride
);
1658 /* Set up formal argument. */
1659 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1660 fini_coarray
->ts
.type
= BT_LOGICAL
;
1661 fini_coarray
->ts
.kind
= 1;
1662 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1663 fini_coarray
->attr
.dummy
= 1;
1664 fini_coarray
->attr
.value
= 1;
1665 fini_coarray
->attr
.artificial
= 1;
1666 gfc_set_sym_referenced (fini_coarray
);
1667 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1668 final
->formal
->next
->next
->sym
= fini_coarray
;
1669 gfc_commit_symbol (fini_coarray
);
1671 /* Return with a NULL() expression but with an interface which has
1672 the formal arguments. */
1673 if (expr_null_wrapper
)
1675 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1676 vtab_final
->ts
.interface
= final
;
1680 /* Local variables. */
1682 gfc_get_symbol ("idx", sub_ns
, &idx
);
1683 idx
->ts
.type
= BT_INTEGER
;
1684 idx
->ts
.kind
= gfc_index_integer_kind
;
1685 idx
->attr
.flavor
= FL_VARIABLE
;
1686 idx
->attr
.artificial
= 1;
1687 gfc_set_sym_referenced (idx
);
1688 gfc_commit_symbol (idx
);
1690 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1691 idx2
->ts
.type
= BT_INTEGER
;
1692 idx2
->ts
.kind
= gfc_index_integer_kind
;
1693 idx2
->attr
.flavor
= FL_VARIABLE
;
1694 idx2
->attr
.artificial
= 1;
1695 gfc_set_sym_referenced (idx2
);
1696 gfc_commit_symbol (idx2
);
1698 gfc_get_symbol ("offset", sub_ns
, &offset
);
1699 offset
->ts
.type
= BT_INTEGER
;
1700 offset
->ts
.kind
= gfc_index_integer_kind
;
1701 offset
->attr
.flavor
= FL_VARIABLE
;
1702 offset
->attr
.artificial
= 1;
1703 gfc_set_sym_referenced (offset
);
1704 gfc_commit_symbol (offset
);
1706 /* Create RANK expression. */
1707 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1708 gfc_current_locus
, 1,
1709 gfc_lval_expr_from_sym (array
));
1710 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1711 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1713 /* Create is_contiguous variable. */
1714 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1715 is_contiguous
->ts
.type
= BT_LOGICAL
;
1716 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1717 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1718 is_contiguous
->attr
.artificial
= 1;
1719 gfc_set_sym_referenced (is_contiguous
);
1720 gfc_commit_symbol (is_contiguous
);
1722 /* Create "sizes(0..rank)" variable, which contains the multiplied
1723 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1724 sizes(2) = sizes(1) * extent(dim=2) etc. */
1725 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1726 sizes
->ts
.type
= BT_INTEGER
;
1727 sizes
->ts
.kind
= gfc_index_integer_kind
;
1728 sizes
->attr
.flavor
= FL_VARIABLE
;
1729 sizes
->attr
.dimension
= 1;
1730 sizes
->attr
.artificial
= 1;
1731 sizes
->as
= gfc_get_array_spec();
1732 sizes
->attr
.intent
= INTENT_INOUT
;
1733 sizes
->as
->type
= AS_EXPLICIT
;
1734 sizes
->as
->rank
= 1;
1735 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1736 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1737 gfc_set_sym_referenced (sizes
);
1738 gfc_commit_symbol (sizes
);
1740 /* Create "strides(1..rank)" variable, which contains the strides per
1742 gfc_get_symbol ("strides", sub_ns
, &strides
);
1743 strides
->ts
.type
= BT_INTEGER
;
1744 strides
->ts
.kind
= gfc_index_integer_kind
;
1745 strides
->attr
.flavor
= FL_VARIABLE
;
1746 strides
->attr
.dimension
= 1;
1747 strides
->attr
.artificial
= 1;
1748 strides
->as
= gfc_get_array_spec();
1749 strides
->attr
.intent
= INTENT_INOUT
;
1750 strides
->as
->type
= AS_EXPLICIT
;
1751 strides
->as
->rank
= 1;
1752 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1753 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1754 gfc_set_sym_referenced (strides
);
1755 gfc_commit_symbol (strides
);
1758 /* Set return value to 0. */
1759 last_code
= gfc_get_code (EXEC_ASSIGN
);
1760 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1761 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1762 sub_ns
->code
= last_code
;
1764 /* Set: is_contiguous = .true. */
1765 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1766 last_code
= last_code
->next
;
1767 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1768 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1769 &gfc_current_locus
, true);
1771 /* Set: sizes(0) = 1. */
1772 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1773 last_code
= last_code
->next
;
1774 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1775 last_code
->expr1
->ref
= gfc_get_ref ();
1776 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1777 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1778 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1779 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1780 last_code
->expr1
->ref
->u
.ar
.start
[0]
1781 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1782 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1783 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1787 strides(idx) = _F._stride (array, dim=idx)
1788 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1789 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1793 iter
= gfc_get_iterator ();
1794 iter
->var
= gfc_lval_expr_from_sym (idx
);
1795 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1796 iter
->end
= gfc_copy_expr (rank
);
1797 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1798 last_code
->next
= gfc_get_code (EXEC_DO
);
1799 last_code
= last_code
->next
;
1800 last_code
->ext
.iterator
= iter
;
1801 last_code
->block
= gfc_get_code (EXEC_DO
);
1803 /* strides(idx) = _F._stride(array,dim=idx). */
1804 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1805 block
= last_code
->block
->next
;
1807 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1808 block
->expr1
->ref
= gfc_get_ref ();
1809 block
->expr1
->ref
->type
= REF_ARRAY
;
1810 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1811 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1812 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1813 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1814 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1816 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1817 gfc_current_locus
, 2,
1818 gfc_lval_expr_from_sym (array
),
1819 gfc_lval_expr_from_sym (idx
));
1821 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1822 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1823 block
= block
->next
;
1825 /* sizes(idx) = ... */
1826 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1827 block
->expr1
->ref
= gfc_get_ref ();
1828 block
->expr1
->ref
->type
= REF_ARRAY
;
1829 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1830 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1831 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1832 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1833 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1835 block
->expr2
= gfc_get_expr ();
1836 block
->expr2
->expr_type
= EXPR_OP
;
1837 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1838 block
->expr2
->where
= gfc_current_locus
;
1841 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1842 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1843 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1844 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1845 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1846 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1847 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1848 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1849 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1850 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1851 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1852 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1853 = gfc_lval_expr_from_sym (idx
);
1854 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1855 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1856 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1857 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1859 /* size(array, dim=idx, kind=index_kind). */
1860 block
->expr2
->value
.op
.op2
1861 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1862 gfc_current_locus
, 3,
1863 gfc_lval_expr_from_sym (array
),
1864 gfc_lval_expr_from_sym (idx
),
1865 gfc_get_int_expr (gfc_index_integer_kind
,
1867 gfc_index_integer_kind
));
1868 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1869 block
->expr2
->ts
= idx
->ts
;
1871 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1872 block
->next
= gfc_get_code (EXEC_IF
);
1873 block
= block
->next
;
1875 block
->block
= gfc_get_code (EXEC_IF
);
1876 block
= block
->block
;
1878 /* if condition: strides(idx) /= sizes(idx-1). */
1879 block
->expr1
= gfc_get_expr ();
1880 block
->expr1
->ts
.type
= BT_LOGICAL
;
1881 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1882 block
->expr1
->expr_type
= EXPR_OP
;
1883 block
->expr1
->where
= gfc_current_locus
;
1884 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1886 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1887 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1888 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1889 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1890 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1891 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1892 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1893 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1895 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1896 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1897 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1898 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1899 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1900 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1901 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1902 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1903 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1904 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1905 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1906 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1907 = gfc_lval_expr_from_sym (idx
);
1908 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1909 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1910 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1911 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1913 /* if body: is_contiguous = .false. */
1914 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1915 block
= block
->next
;
1916 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1917 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1918 &gfc_current_locus
, false);
1920 /* Obtain the size (number of elements) of "array" MINUS ONE,
1921 which is used in the scalarization. */
1922 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1923 nelem
->ts
.type
= BT_INTEGER
;
1924 nelem
->ts
.kind
= gfc_index_integer_kind
;
1925 nelem
->attr
.flavor
= FL_VARIABLE
;
1926 nelem
->attr
.artificial
= 1;
1927 gfc_set_sym_referenced (nelem
);
1928 gfc_commit_symbol (nelem
);
1930 /* nelem = sizes (rank) - 1. */
1931 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1932 last_code
= last_code
->next
;
1934 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1936 last_code
->expr2
= gfc_get_expr ();
1937 last_code
->expr2
->expr_type
= EXPR_OP
;
1938 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1939 last_code
->expr2
->value
.op
.op2
1940 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1941 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1942 last_code
->expr2
->where
= gfc_current_locus
;
1944 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1945 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1946 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1947 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1948 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1949 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1950 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1951 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1953 /* Call final subroutines. We now generate code like:
1955 integer, pointer :: ptr
1957 integer(c_intptr_t) :: i, addr
1959 select case (rank (array))
1961 ! If needed, the array is packed
1962 call final_rank3 (array)
1964 do i = 0, size (array)-1
1965 addr = transfer (c_loc (array), addr) + i * stride
1966 call c_f_pointer (transfer (addr, cptr), ptr)
1967 call elemental_final (ptr)
1971 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
1973 gfc_finalizer
*fini
, *fini_elem
= NULL
;
1975 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
1976 ptr
->ts
.type
= BT_DERIVED
;
1977 ptr
->ts
.u
.derived
= derived
;
1978 ptr
->attr
.flavor
= FL_VARIABLE
;
1979 ptr
->attr
.pointer
= 1;
1980 ptr
->attr
.artificial
= 1;
1981 gfc_set_sym_referenced (ptr
);
1982 gfc_commit_symbol (ptr
);
1984 /* SELECT CASE (RANK (array)). */
1985 last_code
->next
= gfc_get_code (EXEC_SELECT
);
1986 last_code
= last_code
->next
;
1987 last_code
->expr1
= gfc_copy_expr (rank
);
1990 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
1992 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
1993 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
1999 /* CASE (fini_rank). */
2002 block
->block
= gfc_get_code (EXEC_SELECT
);
2003 block
= block
->block
;
2007 block
= gfc_get_code (EXEC_SELECT
);
2008 last_code
->block
= block
;
2010 block
->ext
.block
.case_list
= gfc_get_case ();
2011 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2012 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2013 block
->ext
.block
.case_list
->low
2014 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2015 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2017 block
->ext
.block
.case_list
->low
2018 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2019 block
->ext
.block
.case_list
->high
2020 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2022 /* CALL fini_rank (array) - possibly with packing. */
2023 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2024 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2025 idx
, ptr
, nelem
, strides
,
2026 sizes
, idx2
, offset
, is_contiguous
,
2030 block
->next
= gfc_get_code (EXEC_CALL
);
2031 block
->next
->symtree
= fini
->proc_tree
;
2032 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2033 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2034 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2038 /* Elemental call - scalarized. */
2044 block
->block
= gfc_get_code (EXEC_SELECT
);
2045 block
= block
->block
;
2049 block
= gfc_get_code (EXEC_SELECT
);
2050 last_code
->block
= block
;
2052 block
->ext
.block
.case_list
= gfc_get_case ();
2055 iter
= gfc_get_iterator ();
2056 iter
->var
= gfc_lval_expr_from_sym (idx
);
2057 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2058 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2059 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2060 block
->next
= gfc_get_code (EXEC_DO
);
2061 block
= block
->next
;
2062 block
->ext
.iterator
= iter
;
2063 block
->block
= gfc_get_code (EXEC_DO
);
2065 /* Offset calculation. */
2066 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2067 byte_stride
, rank
, block
->block
,
2071 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2072 + offset, c_ptr), ptr). */
2074 = finalization_scalarizer (array
, ptr
,
2075 gfc_lval_expr_from_sym (offset
),
2077 block
= block
->next
;
2079 /* CALL final_elemental (array). */
2080 block
->next
= gfc_get_code (EXEC_CALL
);
2081 block
= block
->next
;
2082 block
->symtree
= fini_elem
->proc_tree
;
2083 block
->resolved_sym
= fini_elem
->proc_sym
;
2084 block
->ext
.actual
= gfc_get_actual_arglist ();
2085 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2089 /* Finalize and deallocate allocatable components. The same manual
2090 scalarization is used as above. */
2092 if (finalizable_comp
)
2095 gfc_code
*block
= NULL
;
2099 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2100 ptr
->ts
.type
= BT_DERIVED
;
2101 ptr
->ts
.u
.derived
= derived
;
2102 ptr
->attr
.flavor
= FL_VARIABLE
;
2103 ptr
->attr
.pointer
= 1;
2104 ptr
->attr
.artificial
= 1;
2105 gfc_set_sym_referenced (ptr
);
2106 gfc_commit_symbol (ptr
);
2109 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2110 stat
->attr
.flavor
= FL_VARIABLE
;
2111 stat
->attr
.artificial
= 1;
2112 stat
->ts
.type
= BT_INTEGER
;
2113 stat
->ts
.kind
= gfc_default_integer_kind
;
2114 gfc_set_sym_referenced (stat
);
2115 gfc_commit_symbol (stat
);
2118 iter
= gfc_get_iterator ();
2119 iter
->var
= gfc_lval_expr_from_sym (idx
);
2120 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2121 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2122 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2123 last_code
->next
= gfc_get_code (EXEC_DO
);
2124 last_code
= last_code
->next
;
2125 last_code
->ext
.iterator
= iter
;
2126 last_code
->block
= gfc_get_code (EXEC_DO
);
2128 /* Offset calculation. */
2129 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2130 byte_stride
, rank
, last_code
->block
,
2134 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2135 + idx * stride, c_ptr), ptr). */
2136 block
->next
= finalization_scalarizer (array
, ptr
,
2137 gfc_lval_expr_from_sym(offset
),
2139 block
= block
->next
;
2141 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2143 if (comp
== derived
->components
&& derived
->attr
.extension
2144 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2147 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2148 stat
, fini_coarray
, &block
, sub_ns
);
2149 if (!last_code
->block
->next
)
2150 last_code
->block
->next
= block
;
2155 /* Call the finalizer of the ancestor. */
2156 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2158 last_code
->next
= gfc_get_code (EXEC_CALL
);
2159 last_code
= last_code
->next
;
2160 last_code
->symtree
= ancestor_wrapper
->symtree
;
2161 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2163 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2164 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2165 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2166 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2167 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2168 last_code
->ext
.actual
->next
->next
->expr
2169 = gfc_lval_expr_from_sym (fini_coarray
);
2172 gfc_free_expr (rank
);
2173 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2174 vtab_final
->ts
.interface
= final
;
2178 /* Add procedure pointers for all type-bound procedures to a vtab. */
2181 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2183 gfc_symbol
* super_type
;
2185 super_type
= gfc_get_derived_super_type (derived
);
2187 if (super_type
&& (super_type
!= derived
))
2189 /* Make sure that the PPCs appear in the same order as in the parent. */
2190 copy_vtab_proc_comps (super_type
, vtype
);
2191 /* Only needed to get the PPC initializers right. */
2192 add_procs_to_declared_vtab (super_type
, vtype
);
2195 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2196 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2198 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2199 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2203 /* Find or generate the symbol for a derived type's vtab. */
2206 gfc_find_derived_vtab (gfc_symbol
*derived
)
2209 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2210 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2211 gfc_gsymbol
*gsym
= NULL
;
2212 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2214 /* Find the top-level namespace. */
2215 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2219 /* If the type is a class container, use the underlying derived type. */
2220 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2221 derived
= gfc_get_derived_super_type (derived
);
2223 /* Find the gsymbol for the module of use associated derived types. */
2224 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2225 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2226 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2230 /* Work in the gsymbol namespace if the top-level namespace is a module.
2231 This ensures that the vtable is unique, which is required since we use
2232 its address in SELECT TYPE. */
2233 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2234 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2239 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2241 get_unique_hashed_string (tname
, derived
);
2242 sprintf (name
, "__vtab_%s", tname
);
2244 /* Look for the vtab symbol in various namespaces. */
2245 if (gsym
&& gsym
->ns
)
2247 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2252 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2254 gfc_find_symbol (name
, ns
, 0, &vtab
);
2256 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2260 gfc_get_symbol (name
, ns
, &vtab
);
2261 vtab
->ts
.type
= BT_DERIVED
;
2262 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2263 &gfc_current_locus
))
2265 vtab
->attr
.target
= 1;
2266 vtab
->attr
.save
= SAVE_IMPLICIT
;
2267 vtab
->attr
.vtab
= 1;
2268 vtab
->attr
.access
= ACCESS_PUBLIC
;
2269 gfc_set_sym_referenced (vtab
);
2270 sprintf (name
, "__vtype_%s", tname
);
2272 gfc_find_symbol (name
, ns
, 0, &vtype
);
2276 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2279 /* Is this a derived type with recursive allocatable
2281 c
= (derived
->attr
.unlimited_polymorphic
2282 || derived
->attr
.abstract
) ?
2283 NULL
: derived
->components
;
2284 for (; c
; c
= c
->next
)
2285 if (c
->ts
.type
== BT_DERIVED
2286 && c
->ts
.u
.derived
== derived
)
2292 gfc_get_symbol (name
, ns
, &vtype
);
2293 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2294 &gfc_current_locus
))
2296 vtype
->attr
.access
= ACCESS_PUBLIC
;
2297 vtype
->attr
.vtype
= 1;
2298 gfc_set_sym_referenced (vtype
);
2300 /* Add component '_hash'. */
2301 if (!gfc_add_component (vtype
, "_hash", &c
))
2303 c
->ts
.type
= BT_INTEGER
;
2305 c
->attr
.access
= ACCESS_PRIVATE
;
2306 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2307 NULL
, derived
->hash_value
);
2309 /* Add component '_size'. */
2310 if (!gfc_add_component (vtype
, "_size", &c
))
2312 c
->ts
.type
= BT_INTEGER
;
2314 c
->attr
.access
= ACCESS_PRIVATE
;
2315 /* Remember the derived type in ts.u.derived,
2316 so that the correct initializer can be set later on
2317 (in gfc_conv_structure). */
2318 c
->ts
.u
.derived
= derived
;
2319 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2322 /* Add component _extends. */
2323 if (!gfc_add_component (vtype
, "_extends", &c
))
2325 c
->attr
.pointer
= 1;
2326 c
->attr
.access
= ACCESS_PRIVATE
;
2327 if (!derived
->attr
.unlimited_polymorphic
)
2328 parent
= gfc_get_derived_super_type (derived
);
2334 parent_vtab
= gfc_find_derived_vtab (parent
);
2335 c
->ts
.type
= BT_DERIVED
;
2336 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2337 c
->initializer
= gfc_get_expr ();
2338 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2339 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2340 0, &c
->initializer
->symtree
);
2344 c
->ts
.type
= BT_DERIVED
;
2345 c
->ts
.u
.derived
= vtype
;
2346 c
->initializer
= gfc_get_null_expr (NULL
);
2349 if (!derived
->attr
.unlimited_polymorphic
2350 && derived
->components
== NULL
2351 && !derived
->attr
.zero_comp
)
2353 /* At this point an error must have occurred.
2354 Prevent further errors on the vtype components. */
2359 /* Add component _def_init. */
2360 if (!gfc_add_component (vtype
, "_def_init", &c
))
2362 c
->attr
.pointer
= 1;
2363 c
->attr
.artificial
= 1;
2364 c
->attr
.access
= ACCESS_PRIVATE
;
2365 c
->ts
.type
= BT_DERIVED
;
2366 c
->ts
.u
.derived
= derived
;
2367 if (derived
->attr
.unlimited_polymorphic
2368 || derived
->attr
.abstract
)
2369 c
->initializer
= gfc_get_null_expr (NULL
);
2372 /* Construct default initialization variable. */
2373 sprintf (name
, "__def_init_%s", tname
);
2374 gfc_get_symbol (name
, ns
, &def_init
);
2375 def_init
->attr
.target
= 1;
2376 def_init
->attr
.artificial
= 1;
2377 def_init
->attr
.save
= SAVE_IMPLICIT
;
2378 def_init
->attr
.access
= ACCESS_PUBLIC
;
2379 def_init
->attr
.flavor
= FL_VARIABLE
;
2380 gfc_set_sym_referenced (def_init
);
2381 def_init
->ts
.type
= BT_DERIVED
;
2382 def_init
->ts
.u
.derived
= derived
;
2383 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2385 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2388 /* Add component _copy. */
2389 if (!gfc_add_component (vtype
, "_copy", &c
))
2391 c
->attr
.proc_pointer
= 1;
2392 c
->attr
.access
= ACCESS_PRIVATE
;
2393 c
->tb
= XCNEW (gfc_typebound_proc
);
2395 if (derived
->attr
.unlimited_polymorphic
2396 || derived
->attr
.abstract
)
2397 c
->initializer
= gfc_get_null_expr (NULL
);
2400 /* Set up namespace. */
2401 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2402 sub_ns
->sibling
= ns
->contained
;
2403 ns
->contained
= sub_ns
;
2404 sub_ns
->resolved
= 1;
2405 /* Set up procedure symbol. */
2406 sprintf (name
, "__copy_%s", tname
);
2407 gfc_get_symbol (name
, sub_ns
, ©
);
2408 sub_ns
->proc_name
= copy
;
2409 copy
->attr
.flavor
= FL_PROCEDURE
;
2410 copy
->attr
.subroutine
= 1;
2411 copy
->attr
.pure
= 1;
2412 copy
->attr
.artificial
= 1;
2413 copy
->attr
.if_source
= IFSRC_DECL
;
2414 /* This is elemental so that arrays are automatically
2415 treated correctly by the scalarizer. */
2416 copy
->attr
.elemental
= 1;
2417 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2418 copy
->module
= ns
->proc_name
->name
;
2419 gfc_set_sym_referenced (copy
);
2420 /* Set up formal arguments. */
2421 gfc_get_symbol ("src", sub_ns
, &src
);
2422 src
->ts
.type
= BT_DERIVED
;
2423 src
->ts
.u
.derived
= derived
;
2424 src
->attr
.flavor
= FL_VARIABLE
;
2425 src
->attr
.dummy
= 1;
2426 src
->attr
.artificial
= 1;
2427 src
->attr
.intent
= INTENT_IN
;
2428 gfc_set_sym_referenced (src
);
2429 copy
->formal
= gfc_get_formal_arglist ();
2430 copy
->formal
->sym
= src
;
2431 gfc_get_symbol ("dst", sub_ns
, &dst
);
2432 dst
->ts
.type
= BT_DERIVED
;
2433 dst
->ts
.u
.derived
= derived
;
2434 dst
->attr
.flavor
= FL_VARIABLE
;
2435 dst
->attr
.dummy
= 1;
2436 dst
->attr
.artificial
= 1;
2437 dst
->attr
.intent
= INTENT_INOUT
;
2438 gfc_set_sym_referenced (dst
);
2439 copy
->formal
->next
= gfc_get_formal_arglist ();
2440 copy
->formal
->next
->sym
= dst
;
2442 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2443 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2444 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2445 /* Set initializer. */
2446 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2447 c
->ts
.interface
= copy
;
2450 /* Add component _final, which contains a procedure pointer to
2451 a wrapper which handles both the freeing of allocatable
2452 components and the calls to finalization subroutines.
2453 Note: The actual wrapper function can only be generated
2454 at resolution time. */
2455 if (!gfc_add_component (vtype
, "_final", &c
))
2457 c
->attr
.proc_pointer
= 1;
2458 c
->attr
.access
= ACCESS_PRIVATE
;
2459 c
->tb
= XCNEW (gfc_typebound_proc
);
2461 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2463 /* Add component _deallocate. */
2464 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2466 c
->attr
.proc_pointer
= 1;
2467 c
->attr
.access
= ACCESS_PRIVATE
;
2468 c
->tb
= XCNEW (gfc_typebound_proc
);
2470 if (derived
->attr
.unlimited_polymorphic
2471 || derived
->attr
.abstract
2473 c
->initializer
= gfc_get_null_expr (NULL
);
2476 /* Set up namespace. */
2477 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2479 sub_ns
->sibling
= ns
->contained
;
2480 ns
->contained
= sub_ns
;
2481 sub_ns
->resolved
= 1;
2482 /* Set up procedure symbol. */
2483 sprintf (name
, "__deallocate_%s", tname
);
2484 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2485 sub_ns
->proc_name
= dealloc
;
2486 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2487 dealloc
->attr
.subroutine
= 1;
2488 dealloc
->attr
.pure
= 1;
2489 dealloc
->attr
.artificial
= 1;
2490 dealloc
->attr
.if_source
= IFSRC_DECL
;
2492 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2493 dealloc
->module
= ns
->proc_name
->name
;
2494 gfc_set_sym_referenced (dealloc
);
2495 /* Set up formal argument. */
2496 gfc_get_symbol ("arg", sub_ns
, &arg
);
2497 arg
->ts
.type
= BT_DERIVED
;
2498 arg
->ts
.u
.derived
= derived
;
2499 arg
->attr
.flavor
= FL_VARIABLE
;
2500 arg
->attr
.dummy
= 1;
2501 arg
->attr
.artificial
= 1;
2502 arg
->attr
.intent
= INTENT_INOUT
;
2503 arg
->attr
.dimension
= 1;
2504 arg
->attr
.allocatable
= 1;
2505 arg
->as
= gfc_get_array_spec();
2506 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2508 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2510 gfc_set_sym_referenced (arg
);
2511 dealloc
->formal
= gfc_get_formal_arglist ();
2512 dealloc
->formal
->sym
= arg
;
2514 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2515 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2516 sub_ns
->code
->ext
.alloc
.list
->expr
2517 = gfc_lval_expr_from_sym (arg
);
2518 /* Set initializer. */
2519 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2520 c
->ts
.interface
= dealloc
;
2523 /* Add procedure pointers for type-bound procedures. */
2524 if (!derived
->attr
.unlimited_polymorphic
)
2525 add_procs_to_declared_vtab (derived
, vtype
);
2529 vtab
->ts
.u
.derived
= vtype
;
2530 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2537 /* It is unexpected to have some symbols added at resolution or code
2538 generation time. We commit the changes in order to keep a clean state. */
2541 gfc_commit_symbol (vtab
);
2543 gfc_commit_symbol (vtype
);
2545 gfc_commit_symbol (def_init
);
2547 gfc_commit_symbol (copy
);
2549 gfc_commit_symbol (src
);
2551 gfc_commit_symbol (dst
);
2553 gfc_commit_symbol (dealloc
);
2555 gfc_commit_symbol (arg
);
2558 gfc_undo_symbols ();
2564 /* Check if a derived type is finalizable. That is the case if it
2565 (1) has a FINAL subroutine or
2566 (2) has a nonpointer nonallocatable component of finalizable type.
2567 If it is finalizable, return an expression containing the
2568 finalization wrapper. */
2571 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2576 /* (1) Check for FINAL subroutines. */
2577 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2580 /* (2) Check for components of finalizable type. */
2581 for (c
= derived
->components
; c
; c
= c
->next
)
2582 if (c
->ts
.type
== BT_DERIVED
2583 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2584 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2590 /* Make sure vtab is generated. */
2591 vtab
= gfc_find_derived_vtab (derived
);
2594 /* Return finalizer expression. */
2595 gfc_component
*final
;
2596 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2597 gcc_assert (strcmp (final
->name
, "_final") == 0);
2598 gcc_assert (final
->initializer
2599 && final
->initializer
->expr_type
!= EXPR_NULL
);
2600 *final_expr
= final
->initializer
;
2606 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2607 needed to support unlimited polymorphism. */
2610 find_intrinsic_vtab (gfc_typespec
*ts
)
2613 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2614 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2616 /* Find the top-level namespace. */
2617 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2623 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2625 /* Encode all types as TYPENAME_KIND_ including especially character
2626 arrays, whose length is now consistently stored in the _len component
2627 of the class-variable. */
2628 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2629 sprintf (name
, "__vtab_%s", tname
);
2631 /* Look for the vtab symbol in the top-level namespace only. */
2632 gfc_find_symbol (name
, ns
, 0, &vtab
);
2636 gfc_get_symbol (name
, ns
, &vtab
);
2637 vtab
->ts
.type
= BT_DERIVED
;
2638 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2639 &gfc_current_locus
))
2641 vtab
->attr
.target
= 1;
2642 vtab
->attr
.save
= SAVE_IMPLICIT
;
2643 vtab
->attr
.vtab
= 1;
2644 vtab
->attr
.access
= ACCESS_PUBLIC
;
2645 gfc_set_sym_referenced (vtab
);
2646 sprintf (name
, "__vtype_%s", tname
);
2648 gfc_find_symbol (name
, ns
, 0, &vtype
);
2653 gfc_namespace
*sub_ns
;
2654 gfc_namespace
*contained
;
2657 gfc_get_symbol (name
, ns
, &vtype
);
2658 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2659 &gfc_current_locus
))
2661 vtype
->attr
.access
= ACCESS_PUBLIC
;
2662 vtype
->attr
.vtype
= 1;
2663 gfc_set_sym_referenced (vtype
);
2665 /* Add component '_hash'. */
2666 if (!gfc_add_component (vtype
, "_hash", &c
))
2668 c
->ts
.type
= BT_INTEGER
;
2670 c
->attr
.access
= ACCESS_PRIVATE
;
2671 hash
= gfc_intrinsic_hash_value (ts
);
2672 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2675 /* Add component '_size'. */
2676 if (!gfc_add_component (vtype
, "_size", &c
))
2678 c
->ts
.type
= BT_INTEGER
;
2680 c
->attr
.access
= ACCESS_PRIVATE
;
2682 /* Build a minimal expression to make use of
2683 target-memory.c/gfc_element_size for 'size'. Special handling
2684 for character arrays, that are not constant sized: to support
2685 len (str) * kind, only the kind information is stored in the
2687 e
= gfc_get_expr ();
2689 e
->expr_type
= EXPR_VARIABLE
;
2690 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2692 ts
->type
== BT_CHARACTER
2694 : (int)gfc_element_size (e
));
2697 /* Add component _extends. */
2698 if (!gfc_add_component (vtype
, "_extends", &c
))
2700 c
->attr
.pointer
= 1;
2701 c
->attr
.access
= ACCESS_PRIVATE
;
2702 c
->ts
.type
= BT_VOID
;
2703 c
->initializer
= gfc_get_null_expr (NULL
);
2705 /* Add component _def_init. */
2706 if (!gfc_add_component (vtype
, "_def_init", &c
))
2708 c
->attr
.pointer
= 1;
2709 c
->attr
.access
= ACCESS_PRIVATE
;
2710 c
->ts
.type
= BT_VOID
;
2711 c
->initializer
= gfc_get_null_expr (NULL
);
2713 /* Add component _copy. */
2714 if (!gfc_add_component (vtype
, "_copy", &c
))
2716 c
->attr
.proc_pointer
= 1;
2717 c
->attr
.access
= ACCESS_PRIVATE
;
2718 c
->tb
= XCNEW (gfc_typebound_proc
);
2721 if (ts
->type
!= BT_CHARACTER
)
2722 sprintf (name
, "__copy_%s", tname
);
2725 /* __copy is always the same for characters.
2726 Check to see if copy function already exists. */
2727 sprintf (name
, "__copy_character_%d", ts
->kind
);
2728 contained
= ns
->contained
;
2729 for (; contained
; contained
= contained
->sibling
)
2730 if (contained
->proc_name
2731 && strcmp (name
, contained
->proc_name
->name
) == 0)
2733 copy
= contained
->proc_name
;
2738 /* Set up namespace. */
2739 sub_ns
= gfc_get_namespace (ns
, 0);
2740 sub_ns
->sibling
= ns
->contained
;
2741 ns
->contained
= sub_ns
;
2742 sub_ns
->resolved
= 1;
2743 /* Set up procedure symbol. */
2744 gfc_get_symbol (name
, sub_ns
, ©
);
2745 sub_ns
->proc_name
= copy
;
2746 copy
->attr
.flavor
= FL_PROCEDURE
;
2747 copy
->attr
.subroutine
= 1;
2748 copy
->attr
.pure
= 1;
2749 copy
->attr
.if_source
= IFSRC_DECL
;
2750 /* This is elemental so that arrays are automatically
2751 treated correctly by the scalarizer. */
2752 copy
->attr
.elemental
= 1;
2753 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2754 copy
->module
= ns
->proc_name
->name
;
2755 gfc_set_sym_referenced (copy
);
2756 /* Set up formal arguments. */
2757 gfc_get_symbol ("src", sub_ns
, &src
);
2758 src
->ts
.type
= ts
->type
;
2759 src
->ts
.kind
= ts
->kind
;
2760 src
->attr
.flavor
= FL_VARIABLE
;
2761 src
->attr
.dummy
= 1;
2762 src
->attr
.intent
= INTENT_IN
;
2763 gfc_set_sym_referenced (src
);
2764 copy
->formal
= gfc_get_formal_arglist ();
2765 copy
->formal
->sym
= src
;
2766 gfc_get_symbol ("dst", sub_ns
, &dst
);
2767 dst
->ts
.type
= ts
->type
;
2768 dst
->ts
.kind
= ts
->kind
;
2769 dst
->attr
.flavor
= FL_VARIABLE
;
2770 dst
->attr
.dummy
= 1;
2771 dst
->attr
.intent
= INTENT_INOUT
;
2772 gfc_set_sym_referenced (dst
);
2773 copy
->formal
->next
= gfc_get_formal_arglist ();
2774 copy
->formal
->next
->sym
= dst
;
2776 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2777 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2778 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2780 /* Set initializer. */
2781 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2782 c
->ts
.interface
= copy
;
2784 /* Add component _final. */
2785 if (!gfc_add_component (vtype
, "_final", &c
))
2787 c
->attr
.proc_pointer
= 1;
2788 c
->attr
.access
= ACCESS_PRIVATE
;
2789 c
->tb
= XCNEW (gfc_typebound_proc
);
2791 c
->initializer
= gfc_get_null_expr (NULL
);
2793 vtab
->ts
.u
.derived
= vtype
;
2794 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2801 /* It is unexpected to have some symbols added at resolution or code
2802 generation time. We commit the changes in order to keep a clean state. */
2805 gfc_commit_symbol (vtab
);
2807 gfc_commit_symbol (vtype
);
2809 gfc_commit_symbol (copy
);
2811 gfc_commit_symbol (src
);
2813 gfc_commit_symbol (dst
);
2816 gfc_undo_symbols ();
2822 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2825 gfc_find_vtab (gfc_typespec
*ts
)
2832 return gfc_find_derived_vtab (ts
->u
.derived
);
2834 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2836 return find_intrinsic_vtab (ts
);
2841 /* General worker function to find either a type-bound procedure or a
2842 type-bound user operator. */
2845 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2846 const char* name
, bool noaccess
, bool uop
,
2852 /* Set default to failure. */
2856 if (derived
->f2k_derived
)
2857 /* Set correct symbol-root. */
2858 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2859 : derived
->f2k_derived
->tb_sym_root
);
2863 /* Try to find it in the current type's namespace. */
2864 res
= gfc_find_symtree (root
, name
);
2865 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2871 if (!noaccess
&& derived
->attr
.use_assoc
2872 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2875 gfc_error ("%qs of %qs is PRIVATE at %L",
2876 name
, derived
->name
, where
);
2884 /* Otherwise, recurse on parent type if derived is an extension. */
2885 if (derived
->attr
.extension
)
2887 gfc_symbol
* super_type
;
2888 super_type
= gfc_get_derived_super_type (derived
);
2889 gcc_assert (super_type
);
2891 return find_typebound_proc_uop (super_type
, t
, name
,
2892 noaccess
, uop
, where
);
2895 /* Nothing found. */
2900 /* Find a type-bound procedure or user operator by name for a derived-type
2901 (looking recursively through the super-types). */
2904 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
2905 const char* name
, bool noaccess
, locus
* where
)
2907 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2911 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
2912 const char* name
, bool noaccess
, locus
* where
)
2914 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2918 /* Find a type-bound intrinsic operator looking recursively through the
2919 super-type hierarchy. */
2922 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
2923 gfc_intrinsic_op op
, bool noaccess
,
2926 gfc_typebound_proc
* res
;
2928 /* Set default to failure. */
2932 /* Try to find it in the current type's namespace. */
2933 if (derived
->f2k_derived
)
2934 res
= derived
->f2k_derived
->tb_op
[op
];
2939 if (res
&& !res
->error
)
2945 if (!noaccess
&& derived
->attr
.use_assoc
2946 && res
->access
== ACCESS_PRIVATE
)
2949 gfc_error ("%qs of %qs is PRIVATE at %L",
2950 gfc_op2string (op
), derived
->name
, where
);
2958 /* Otherwise, recurse on parent type if derived is an extension. */
2959 if (derived
->attr
.extension
)
2961 gfc_symbol
* super_type
;
2962 super_type
= gfc_get_derived_super_type (derived
);
2963 gcc_assert (super_type
);
2965 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2969 /* Nothing found. */
2974 /* Get a typebound-procedure symtree or create and insert it if not yet
2975 present. This is like a very simplified version of gfc_get_sym_tree for
2976 tbp-symtrees rather than regular ones. */
2979 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2981 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
2982 return result
? result
: gfc_new_symtree (root
, name
);