1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009, 2010, 2011, 2012, 2013
3 Free Software Foundation, Inc.
4 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
5 and Janus Weil <janus@gcc.gnu.org>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* class.c -- This file contains the front end functions needed to service
25 the implementation of Fortran 2003 polymorphism and other
26 object-oriented features. */
29 /* Outline of the internal representation:
31 Each CLASS variable is encapsulated by a class container, which is a
32 structure with two fields:
33 * _data: A pointer to the actual data of the variable. This field has the
34 declared type of the class variable and its attributes
35 (pointer/allocatable/dimension/...).
36 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
38 For each derived type we set up a "vtable" entry, i.e. a structure with the
40 * _hash: A hash value serving as a unique identifier for this type.
41 * _size: The size in bytes of the derived type.
42 * _extends: A pointer to the vtable entry of the parent derived type.
43 * _def_init: A pointer to a default initialized variable of this type.
44 * _copy: A procedure pointer to a copying procedure.
45 * _final: A procedure pointer to a wrapper function, which frees
46 allocatable components and calls FINAL subroutines.
48 After these follow procedure pointer components for the specific
49 type-bound procedures. */
54 #include "coretypes.h"
56 #include "constructor.h"
58 /* Inserts a derived type component reference in a data reference chain.
59 TS: base type of the ref chain so far, in which we will pick the component
60 REF: the address of the GFC_REF pointer to update
61 NAME: name of the component to insert
62 Note that component insertion makes sense only if we are at the end of
63 the chain (*REF == NULL) or if we are adding a missing "_data" component
64 to access the actual contents of a class object. */
67 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
72 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
73 type_sym
= ts
->u
.derived
;
75 new_ref
= gfc_get_ref ();
76 new_ref
->type
= REF_COMPONENT
;
78 new_ref
->u
.c
.sym
= type_sym
;
79 new_ref
->u
.c
.component
= gfc_find_component (type_sym
, name
, true, true);
80 gcc_assert (new_ref
->u
.c
.component
);
86 /* We need to update the base type in the trailing reference chain to
87 that of the new component. */
89 gcc_assert (strcmp (name
, "_data") == 0);
91 if (new_ref
->next
->type
== REF_COMPONENT
)
93 else if (new_ref
->next
->type
== REF_ARRAY
94 && new_ref
->next
->next
95 && new_ref
->next
->next
->type
== REF_COMPONENT
)
96 next
= new_ref
->next
->next
;
100 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
101 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
102 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
110 /* Tells whether we need to add a "_data" reference to access REF subobject
111 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
112 object accessed by REF is a variable; in other words it is a full object,
116 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
118 /* Only class containers may need the "_data" reference. */
119 if (ts
->type
!= BT_CLASS
)
122 /* Accessing a class container with an array reference is certainly wrong. */
123 if (ref
->type
!= REF_COMPONENT
)
126 /* Accessing the class container's fields is fine. */
127 if (ref
->u
.c
.component
->name
[0] == '_')
130 /* At this point we have a class container with a non class container's field
131 component reference. We don't want to add the "_data" component if we are
132 at the first reference and the symbol's type is an extended derived type.
133 In that case, conv_parent_component_references will do the right thing so
134 it is not absolutely necessary. Omitting it prevents a regression (see
135 class_41.f03) in the interface mapping mechanism. When evaluating string
136 lengths depending on dummy arguments, we create a fake symbol with a type
137 equal to that of the dummy type. However, because of type extension,
138 the backend type (corresponding to the actual argument) can have a
139 different (extended) type. Adding the "_data" component explicitly, using
140 the base type, confuses the gfc_conv_component_ref code which deals with
141 the extended type. */
142 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
145 /* We have a class container with a non class container's field component
146 reference that doesn't fall into the above. */
151 /* Browse through a data reference chain and add the missing "_data" references
152 when a subobject of a class object is accessed without it.
153 Note that it doesn't add the "_data" reference when the class container
154 is the last element in the reference chain. */
157 gfc_fix_class_refs (gfc_expr
*e
)
162 if ((e
->expr_type
!= EXPR_VARIABLE
163 && e
->expr_type
!= EXPR_FUNCTION
)
164 || (e
->expr_type
== EXPR_FUNCTION
165 && e
->value
.function
.isym
!= NULL
))
168 if (e
->expr_type
== EXPR_VARIABLE
)
169 ts
= &e
->symtree
->n
.sym
->ts
;
174 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
175 if (e
->value
.function
.esym
!= NULL
)
176 func
= e
->value
.function
.esym
;
178 func
= e
->symtree
->n
.sym
;
180 if (func
->result
!= NULL
)
181 ts
= &func
->result
->ts
;
186 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
188 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
189 insert_component_ref (ts
, ref
, "_data");
191 if ((*ref
)->type
== REF_COMPONENT
)
192 ts
= &(*ref
)->u
.c
.component
->ts
;
197 /* Insert a reference to the component of the given name.
198 Only to be used with CLASS containers and vtables. */
201 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
203 gfc_ref
**tail
= &(e
->ref
);
204 gfc_ref
*next
= NULL
;
205 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
206 while (*tail
!= NULL
)
208 if ((*tail
)->type
== REF_COMPONENT
)
210 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
212 && (*tail
)->next
->type
== REF_ARRAY
213 && (*tail
)->next
->next
== NULL
)
215 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
217 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
219 tail
= &((*tail
)->next
);
221 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
223 (*tail
) = gfc_get_ref();
224 (*tail
)->next
= next
;
225 (*tail
)->type
= REF_COMPONENT
;
226 (*tail
)->u
.c
.sym
= derived
;
227 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
228 gcc_assert((*tail
)->u
.c
.component
);
230 e
->ts
= (*tail
)->u
.c
.component
->ts
;
234 /* This is used to add both the _data component reference and an array
235 reference to class expressions. Used in translation of intrinsic
236 array inquiry functions. */
239 gfc_add_class_array_ref (gfc_expr
*e
)
241 int rank
= CLASS_DATA (e
)->as
->rank
;
242 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
244 gfc_add_component_ref (e
, "_data");
246 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
249 if (ref
->type
!= REF_ARRAY
)
251 ref
->next
= gfc_get_ref ();
253 ref
->type
= REF_ARRAY
;
254 ref
->u
.ar
.type
= AR_FULL
;
260 /* Unfortunately, class array expressions can appear in various conditions;
261 with and without both _data component and an arrayspec. This function
262 deals with that variability. The previous reference to 'ref' is to a
266 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
268 bool no_data
= false;
269 bool with_data
= false;
271 /* An array reference with no _data component. */
272 if (ref
&& ref
->type
== REF_ARRAY
274 && ref
->u
.ar
.type
!= AR_ELEMENT
)
277 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
281 /* Cover cases where _data appears, with or without an array ref. */
282 if (ref
&& ref
->type
== REF_COMPONENT
283 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
291 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
293 && ref
->type
== REF_COMPONENT
294 && ref
->next
->type
== REF_ARRAY
295 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
299 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
303 return no_data
|| with_data
;
307 /* Returns true if the expression contains a reference to a class
308 array. Notice that class array elements return false. */
311 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
321 /* Is this a class array object? ie. Is the symbol of type class? */
323 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
324 && CLASS_DATA (e
->symtree
->n
.sym
)
325 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
326 && class_array_ref_detected (e
->ref
, full_array
))
329 /* Or is this a class array component reference? */
330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
332 if (ref
->type
== REF_COMPONENT
333 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
334 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
335 && class_array_ref_detected (ref
->next
, full_array
))
343 /* Returns true if the expression is a reference to a class
344 scalar. This function is necessary because such expressions
345 can be dressed with a reference to the _data component and so
346 have a type other than BT_CLASS. */
349 gfc_is_class_scalar_expr (gfc_expr
*e
)
356 /* Is this a class object? */
358 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
359 && CLASS_DATA (e
->symtree
->n
.sym
)
360 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
362 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
363 && e
->ref
->next
== NULL
)))
366 /* Or is the final reference BT_CLASS or _data? */
367 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
369 if (ref
->type
== REF_COMPONENT
370 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
371 && CLASS_DATA (ref
->u
.c
.component
)
372 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
373 && (ref
->next
== NULL
374 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
375 && ref
->next
->next
== NULL
)))
383 /* Tells whether the expression E is a reference to a (scalar) class container.
384 Scalar because array class containers usually have an array reference after
385 them, and gfc_fix_class_refs will add the missing "_data" component reference
389 gfc_is_class_container_ref (gfc_expr
*e
)
394 if (e
->expr_type
!= EXPR_VARIABLE
)
395 return e
->ts
.type
== BT_CLASS
;
397 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
402 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
404 if (ref
->type
!= REF_COMPONENT
)
406 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
416 /* Build a NULL initializer for CLASS pointers,
417 initializing the _data component to NULL and
418 the _vptr component to the declared type. */
421 gfc_class_null_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
425 gfc_symbol
*vtab
= NULL
;
426 bool is_unlimited_polymorphic
;
428 is_unlimited_polymorphic
= ts
->u
.derived
429 && ts
->u
.derived
->components
->ts
.u
.derived
430 && ts
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
;
432 if (is_unlimited_polymorphic
&& init_expr
)
433 vtab
= gfc_find_intrinsic_vtab (&ts
->u
.derived
->components
->ts
);
435 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
437 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
438 &ts
->u
.derived
->declared_at
);
441 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
443 gfc_constructor
*ctor
= gfc_constructor_get();
444 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
445 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
447 ctor
->expr
= gfc_get_null_expr (NULL
);
448 gfc_constructor_append (&init
->value
.constructor
, ctor
);
455 /* Create a unique string identifier for a derived type, composed of its name
456 and module name. This is used to construct unique names for the class
457 containers and vtab symbols. */
460 get_unique_type_string (char *string
, gfc_symbol
*derived
)
462 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
463 if (derived
->attr
.unlimited_polymorphic
)
464 sprintf (dt_name
, "%s", "$tar");
466 sprintf (dt_name
, "%s", derived
->name
);
467 dt_name
[0] = TOUPPER (dt_name
[0]);
468 if (derived
->attr
.unlimited_polymorphic
)
469 sprintf (string
, "_%s", dt_name
);
470 else if (derived
->module
)
471 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
472 else if (derived
->ns
->proc_name
)
473 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
475 sprintf (string
, "_%s", dt_name
);
479 /* A relative of 'get_unique_type_string' which makes sure the generated
480 string will not be too long (replacing it by a hash string if needed). */
483 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
485 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
486 get_unique_type_string (&tmp
[0], derived
);
487 /* If string is too long, use hash value in hex representation (allow for
488 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
489 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
490 where %d is the (co)rank which can be up to n = 15. */
491 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
493 int h
= gfc_hash_value (derived
);
494 sprintf (string
, "%X", h
);
497 strcpy (string
, tmp
);
501 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
504 gfc_hash_value (gfc_symbol
*sym
)
506 unsigned int hash
= 0;
507 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
510 get_unique_type_string (&c
[0], sym
);
513 for (i
= 0; i
< len
; i
++)
514 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
516 /* Return the hash but take the modulus for the sake of module read,
517 even though this slightly increases the chance of collision. */
518 return (hash
% 100000000);
522 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
525 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
527 unsigned int hash
= 0;
528 const char *c
= gfc_typename (ts
);
533 for (i
= 0; i
< len
; i
++)
534 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
536 /* Return the hash but take the modulus for the sake of module read,
537 even though this slightly increases the chance of collision. */
538 return (hash
% 100000000);
542 /* Build a polymorphic CLASS entity, using the symbol that comes from
543 build_sym. A CLASS entity is represented by an encapsulating type,
544 which contains the declared type as '_data' component, plus a pointer
545 component '_vptr' which determines the dynamic type. */
548 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
549 gfc_array_spec
**as
, bool delayed_vtab
)
551 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
560 if (*as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
562 gfc_error ("Assumed size polymorphic objects or components, such "
563 "as that at %C, have not yet been implemented");
568 /* Class container has already been built. */
571 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
572 || attr
->select_type_temporary
;
575 /* We can not build the class container yet. */
578 /* Determine the name of the encapsulating type. */
579 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
580 get_unique_hashed_string (tname
, ts
->u
.derived
);
581 if ((*as
) && attr
->allocatable
)
582 sprintf (name
, "__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
583 else if ((*as
) && attr
->pointer
)
584 sprintf (name
, "__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
586 sprintf (name
, "__class_%s_%d_%d", tname
, rank
, (*as
)->corank
);
587 else if (attr
->pointer
)
588 sprintf (name
, "__class_%s_p", tname
);
589 else if (attr
->allocatable
)
590 sprintf (name
, "__class_%s_a", tname
);
592 sprintf (name
, "__class_%s", tname
);
594 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
596 /* Find the top-level namespace. */
597 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
602 ns
= ts
->u
.derived
->ns
;
604 gfc_find_symbol (name
, ns
, 0, &fclass
);
608 /* If not there, create a new symbol. */
609 fclass
= gfc_new_symbol (name
, ns
);
610 st
= gfc_new_symtree (&ns
->sym_root
, name
);
612 gfc_set_sym_referenced (fclass
);
614 fclass
->ts
.type
= BT_UNKNOWN
;
615 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
616 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
617 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
618 if (gfc_add_flavor (&fclass
->attr
, FL_DERIVED
,
619 NULL
, &gfc_current_locus
) == FAILURE
)
622 /* Add component '_data'. */
623 if (gfc_add_component (fclass
, "_data", &c
) == FAILURE
)
626 c
->ts
.type
= BT_DERIVED
;
627 c
->attr
.access
= ACCESS_PRIVATE
;
628 c
->ts
.u
.derived
= ts
->u
.derived
;
629 c
->attr
.class_pointer
= attr
->pointer
;
630 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
631 || attr
->select_type_temporary
;
632 c
->attr
.allocatable
= attr
->allocatable
;
633 c
->attr
.dimension
= attr
->dimension
;
634 c
->attr
.codimension
= attr
->codimension
;
635 c
->attr
.abstract
= fclass
->attr
.abstract
;
637 c
->initializer
= NULL
;
639 /* Add component '_vptr'. */
640 if (gfc_add_component (fclass
, "_vptr", &c
) == FAILURE
)
642 c
->ts
.type
= BT_DERIVED
;
644 || (ts
->u
.derived
->f2k_derived
645 && ts
->u
.derived
->f2k_derived
->finalizers
))
646 c
->ts
.u
.derived
= NULL
;
649 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
651 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
653 c
->attr
.access
= ACCESS_PRIVATE
;
657 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
659 /* Since the extension field is 8 bit wide, we can only have
660 up to 255 extension levels. */
661 if (ts
->u
.derived
->attr
.extension
== 255)
663 gfc_error ("Maximum extension level reached with type '%s' at %L",
664 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
668 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
669 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
672 fclass
->attr
.is_class
= 1;
673 ts
->u
.derived
= fclass
;
674 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
680 /* Add a procedure pointer component to the vtype
681 to represent a specific type-bound procedure. */
684 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
688 if (tb
->non_overridable
)
691 c
= gfc_find_component (vtype
, name
, true, true);
695 /* Add procedure component. */
696 if (gfc_add_component (vtype
, name
, &c
) == FAILURE
)
700 c
->tb
= XCNEW (gfc_typebound_proc
);
703 c
->attr
.procedure
= 1;
704 c
->attr
.proc_pointer
= 1;
705 c
->attr
.flavor
= FL_PROCEDURE
;
706 c
->attr
.access
= ACCESS_PRIVATE
;
707 c
->attr
.external
= 1;
709 c
->attr
.if_source
= IFSRC_IFBODY
;
711 else if (c
->attr
.proc_pointer
&& c
->tb
)
719 c
->ts
.interface
= tb
->u
.specific
->n
.sym
;
721 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
726 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
729 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
735 add_procs_to_declared_vtab1 (st
->left
, vtype
);
738 add_procs_to_declared_vtab1 (st
->right
, vtype
);
740 if (st
->n
.tb
&& !st
->n
.tb
->error
741 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
742 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
746 /* Copy procedure pointers components from the parent type. */
749 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
754 vtab
= gfc_find_derived_vtab (declared
);
756 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
758 if (gfc_find_component (vtype
, cmp
->name
, true, true))
761 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
766 /* Returns true if any of its nonpointer nonallocatable components or
767 their nonpointer nonallocatable subcomponents has a finalization
771 has_finalizer_component (gfc_symbol
*derived
)
775 for (c
= derived
->components
; c
; c
= c
->next
)
777 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->f2k_derived
778 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
781 if (c
->ts
.type
== BT_DERIVED
782 && !c
->attr
.pointer
&& !c
->attr
.allocatable
783 && has_finalizer_component (c
->ts
.u
.derived
))
790 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
791 neither allocatable nor a pointer but has a finalizer, call it. If it
792 is a nonpointer component with allocatable components or has finalizers, walk
793 them. Either of them is required; other nonallocatables and pointers aren't
795 Note: If the component is allocatable, the DEALLOCATE handling takes care
796 of calling the appropriate finalizers, coarray deregistering, and
797 deallocation of allocatable subcomponents. */
800 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
801 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
)
806 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
807 && !comp
->attr
.allocatable
)
810 if ((comp
->ts
.type
== BT_DERIVED
&& comp
->attr
.pointer
)
811 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
812 && CLASS_DATA (comp
)->attr
.pointer
))
815 if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.allocatable
816 && (comp
->ts
.u
.derived
->f2k_derived
== NULL
817 || comp
->ts
.u
.derived
->f2k_derived
->finalizers
== NULL
)
818 && !has_finalizer_component (comp
->ts
.u
.derived
))
821 e
= gfc_copy_expr (expr
);
823 e
->ref
= ref
= gfc_get_ref ();
826 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
828 ref
->next
= gfc_get_ref ();
831 ref
->type
= REF_COMPONENT
;
832 ref
->u
.c
.sym
= derived
;
833 ref
->u
.c
.component
= comp
;
836 if (comp
->attr
.dimension
837 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
838 && CLASS_DATA (comp
)->attr
.dimension
))
840 ref
->next
= gfc_get_ref ();
841 ref
->next
->type
= REF_ARRAY
;
842 ref
->next
->u
.ar
.type
= AR_FULL
;
843 ref
->next
->u
.ar
.dimen
= 0;
844 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
846 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
849 /* Call DEALLOCATE (comp, stat=ignore). */
850 if (comp
->attr
.allocatable
851 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
852 && CLASS_DATA (comp
)->attr
.allocatable
))
854 gfc_code
*dealloc
, *block
= NULL
;
856 /* Add IF (fini_coarray). */
857 if (comp
->attr
.codimension
858 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
859 && CLASS_DATA (comp
)->attr
.allocatable
))
861 block
= XCNEW (gfc_code
);
864 (*code
)->next
= block
;
865 (*code
) = (*code
)->next
;
870 block
->loc
= gfc_current_locus
;
873 block
->block
= XCNEW (gfc_code
);
874 block
= block
->block
;
875 block
->loc
= gfc_current_locus
;
877 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
880 dealloc
= XCNEW (gfc_code
);
881 dealloc
->op
= EXEC_DEALLOCATE
;
882 dealloc
->loc
= gfc_current_locus
;
884 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
885 dealloc
->ext
.alloc
.list
->expr
= e
;
886 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
889 block
->next
= dealloc
;
892 (*code
)->next
= dealloc
;
893 (*code
) = (*code
)->next
;
898 else if (comp
->ts
.type
== BT_DERIVED
899 && comp
->ts
.u
.derived
->f2k_derived
900 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
902 /* Call FINAL_WRAPPER (comp); */
903 gfc_code
*final_wrap
;
907 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
908 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
909 if (strcmp (c
->name
, "_final") == 0)
913 final_wrap
= XCNEW (gfc_code
);
914 final_wrap
->op
= EXEC_CALL
;
915 final_wrap
->loc
= gfc_current_locus
;
916 final_wrap
->loc
= gfc_current_locus
;
917 final_wrap
->symtree
= c
->initializer
->symtree
;
918 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
919 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
920 final_wrap
->ext
.actual
->expr
= e
;
924 (*code
)->next
= final_wrap
;
925 (*code
) = (*code
)->next
;
928 (*code
) = final_wrap
;
934 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
935 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
);
941 /* Generate code equivalent to
942 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
943 + offset, c_ptr), ptr). */
946 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
947 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
950 gfc_expr
*expr
, *expr2
;
953 block
= XCNEW (gfc_code
);
954 block
->op
= EXEC_CALL
;
955 block
->loc
= gfc_current_locus
;
956 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
957 block
->resolved_sym
= block
->symtree
->n
.sym
;
958 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
959 block
->resolved_sym
->attr
.intrinsic
= 1;
960 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
961 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
962 gfc_commit_symbol (block
->resolved_sym
);
964 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
965 block
->ext
.actual
= gfc_get_actual_arglist ();
966 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
967 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
970 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
973 expr2
= gfc_get_expr ();
974 expr2
->expr_type
= EXPR_FUNCTION
;
975 expr2
->value
.function
.name
= "__transfer0";
976 expr2
->value
.function
.isym
977 = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER
);
978 /* Set symtree for -fdump-parse-tree. */
979 gfc_get_sym_tree ("transfer", sub_ns
, &expr2
->symtree
, false);
980 expr2
->symtree
->n
.sym
->intmod_sym_id
= GFC_ISYM_TRANSFER
;
981 expr2
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
982 expr2
->symtree
->n
.sym
->attr
.intrinsic
= 1;
983 gfc_commit_symbol (expr2
->symtree
->n
.sym
);
984 expr2
->value
.function
.actual
= gfc_get_actual_arglist ();
985 expr2
->value
.function
.actual
->expr
986 = gfc_lval_expr_from_sym (array
);
987 expr2
->ts
.type
= BT_INTEGER
;
988 expr2
->ts
.kind
= gfc_index_integer_kind
;
990 /* TRANSFER's second argument: 0_c_intptr_t. */
991 expr2
->value
.function
.actual
= gfc_get_actual_arglist ();
992 expr2
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
993 expr2
->value
.function
.actual
->next
->expr
994 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
995 expr2
->value
.function
.actual
->next
->next
= gfc_get_actual_arglist ();
997 /* TRANSFER's first argument: C_LOC (array). */
998 expr
= gfc_get_expr ();
999 expr
->expr_type
= EXPR_FUNCTION
;
1000 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1001 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1002 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1003 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1004 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1005 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1006 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1007 expr
->value
.function
.actual
->expr
1008 = gfc_lval_expr_from_sym (array
);
1009 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1010 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1011 expr
->ts
.type
= BT_INTEGER
;
1012 expr
->ts
.kind
= gfc_index_integer_kind
;
1013 expr2
->value
.function
.actual
->expr
= expr
;
1015 /* <array addr> + <offset>. */
1016 block
->ext
.actual
->expr
= gfc_get_expr ();
1017 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1018 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1019 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1020 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1021 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1023 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1024 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1025 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1026 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1032 /* Calculates the offset to the (idx+1)th element of an array, taking the
1033 stride into account. It generates the code:
1036 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1038 offset = offset * byte_stride. */
1041 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1042 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1043 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1044 gfc_code
*block
, gfc_namespace
*sub_ns
)
1047 gfc_expr
*expr
, *expr2
;
1050 block
->next
= XCNEW (gfc_code
);
1051 block
= block
->next
;
1052 block
->op
= EXEC_ASSIGN
;
1053 block
->loc
= gfc_current_locus
;
1054 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1055 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1058 iter
= gfc_get_iterator ();
1059 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1060 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1061 iter
->end
= gfc_copy_expr (rank
);
1062 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1063 block
->next
= XCNEW (gfc_code
);
1064 block
= block
->next
;
1065 block
->op
= EXEC_DO
;
1066 block
->loc
= gfc_current_locus
;
1067 block
->ext
.iterator
= iter
;
1068 block
->block
= gfc_get_code ();
1069 block
->block
->op
= EXEC_DO
;
1071 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1074 /* mod (idx, sizes(idx2)). */
1075 expr
= gfc_get_expr ();
1076 expr
->expr_type
= EXPR_FUNCTION
;
1077 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
1078 gfc_get_sym_tree ("mod", sub_ns
, &expr
->symtree
, false);
1079 expr
->symtree
->n
.sym
->intmod_sym_id
= GFC_ISYM_MOD
;
1080 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1081 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1082 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1083 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1084 expr
->value
.function
.actual
->expr
= gfc_lval_expr_from_sym (idx
);
1085 expr
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1086 expr
->value
.function
.actual
->next
->expr
= gfc_lval_expr_from_sym (sizes
);
1087 expr
->value
.function
.actual
->next
->expr
->ref
= gfc_get_ref ();
1088 expr
->value
.function
.actual
->next
->expr
->ref
->type
= REF_ARRAY
;
1089 expr
->value
.function
.actual
->next
->expr
->ref
->u
.ar
.as
= sizes
->as
;
1090 expr
->value
.function
.actual
->next
->expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1091 expr
->value
.function
.actual
->next
->expr
->ref
->u
.ar
.dimen
= 1;
1092 expr
->value
.function
.actual
->next
->expr
->ref
->u
.ar
.dimen_type
[0]
1094 expr
->value
.function
.actual
->next
->expr
->ref
->u
.ar
.start
[0]
1095 = gfc_lval_expr_from_sym (idx2
);
1098 /* (...) / sizes(idx2-1). */
1099 expr2
= gfc_get_expr ();
1100 expr2
->expr_type
= EXPR_OP
;
1101 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1102 expr2
->value
.op
.op1
= expr
;
1103 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1104 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1105 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1106 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1107 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1108 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1109 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1110 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1111 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1112 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1113 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1114 = gfc_lval_expr_from_sym (idx2
);
1115 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1116 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1117 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1118 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1119 expr2
->ts
= idx
->ts
;
1121 /* ... * strides(idx2). */
1122 expr
= gfc_get_expr ();
1123 expr
->expr_type
= EXPR_OP
;
1124 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1125 expr
->value
.op
.op1
= expr2
;
1126 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1127 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1128 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1129 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1130 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1131 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1132 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1133 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1136 /* offset = offset + ... */
1137 block
->block
->next
= XCNEW (gfc_code
);
1138 block
->block
->next
->op
= EXEC_ASSIGN
;
1139 block
->block
->next
->loc
= gfc_current_locus
;
1140 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1141 block
->block
->next
->expr2
= gfc_get_expr ();
1142 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1143 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1144 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1145 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1146 block
->block
->next
->expr2
->ts
= idx
->ts
;
1148 /* After the loop: offset = offset * byte_stride. */
1149 block
->next
= XCNEW (gfc_code
);
1150 block
= block
->next
;
1151 block
->op
= EXEC_ASSIGN
;
1152 block
->loc
= gfc_current_locus
;
1153 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1154 block
->expr2
= gfc_get_expr ();
1155 block
->expr2
->expr_type
= EXPR_OP
;
1156 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1157 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1158 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1159 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1164 /* Insert code of the following form:
1167 integer(c_intptr_t) :: i
1169 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1170 && (is_contiguous || !final_rank3->attr.contiguous
1171 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1172 || 0 == STORAGE_SIZE (array)) then
1173 call final_rank3 (array)
1176 integer(c_intptr_t) :: offset, j
1177 type(t) :: tmp(shape (array))
1179 do i = 0, size (array)-1
1180 offset = obtain_offset(i, strides, sizes, byte_stride)
1181 addr = transfer (c_loc (array), addr) + offset
1182 call c_f_pointer (transfer (addr, cptr), ptr)
1184 addr = transfer (c_loc (tmp), addr)
1185 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1186 call c_f_pointer (transfer (addr, cptr), ptr2)
1189 call final_rank3 (tmp)
1195 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1196 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1197 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1198 gfc_symbol
*nelem
, gfc_symtree
*size_intr
,
1199 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1200 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1201 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1202 gfc_namespace
*sub_ns
)
1204 gfc_symbol
*tmp_array
, *ptr2
;
1205 gfc_expr
*size_expr
, *offset2
, *expr
;
1211 block
->next
= XCNEW (gfc_code
);
1212 block
= block
->next
;
1213 block
->loc
= gfc_current_locus
;
1214 block
->op
= EXEC_IF
;
1216 block
->block
= XCNEW (gfc_code
);
1217 block
= block
->block
;
1218 block
->loc
= gfc_current_locus
;
1219 block
->op
= EXEC_IF
;
1221 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1222 size_expr
= gfc_get_expr ();
1223 size_expr
->where
= gfc_current_locus
;
1224 size_expr
->expr_type
= EXPR_OP
;
1225 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1227 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1228 size_expr
->value
.op
.op1
= gfc_get_expr ();
1229 size_expr
->value
.op
.op1
->where
= gfc_current_locus
;
1230 size_expr
->value
.op
.op1
->expr_type
= EXPR_FUNCTION
;
1231 size_expr
->value
.op
.op1
->value
.function
.isym
1232 = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE
);
1233 gfc_get_sym_tree ("storage_size", sub_ns
, &size_expr
->value
.op
.op1
->symtree
,
1235 size_expr
->value
.op
.op1
->symtree
->n
.sym
->intmod_sym_id
1236 = GFC_ISYM_STORAGE_SIZE
;
1237 size_expr
->value
.op
.op1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1238 size_expr
->value
.op
.op1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1239 gfc_commit_symbol (size_expr
->value
.op
.op1
->symtree
->n
.sym
);
1240 size_expr
->value
.op
.op1
->value
.function
.actual
= gfc_get_actual_arglist ();
1241 size_expr
->value
.op
.op1
->value
.function
.actual
->expr
1242 = gfc_lval_expr_from_sym (array
);
1243 size_expr
->value
.op
.op1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1244 size_expr
->value
.op
.op1
->value
.function
.actual
->next
->expr
1245 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1247 /* NUMERIC_STORAGE_SIZE. */
1248 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1249 gfc_character_storage_size
);
1250 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1251 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1253 /* IF condition: (stride == size_expr
1254 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1256 || 0 == size_expr. */
1257 block
->expr1
= gfc_get_expr ();
1258 block
->expr1
->expr_type
= EXPR_FUNCTION
;
1259 block
->expr1
->ts
.type
= BT_LOGICAL
;
1260 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1261 block
->expr1
->expr_type
= EXPR_OP
;
1262 block
->expr1
->where
= gfc_current_locus
;
1264 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1266 /* byte_stride == size_expr */
1267 expr
= gfc_get_expr ();
1268 expr
->ts
.type
= BT_LOGICAL
;
1269 expr
->ts
.kind
= gfc_default_logical_kind
;
1270 expr
->expr_type
= EXPR_OP
;
1271 expr
->where
= gfc_current_locus
;
1272 expr
->value
.op
.op
= INTRINSIC_EQ
;
1274 = gfc_lval_expr_from_sym (byte_stride
);
1275 expr
->value
.op
.op2
= size_expr
;
1277 /* If strides aren't allowd (not assumed shape or CONTIGUOUS),
1278 add is_contiguous check. */
1279 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1280 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1283 expr2
= gfc_get_expr ();
1284 expr2
->ts
.type
= BT_LOGICAL
;
1285 expr2
->ts
.kind
= gfc_default_logical_kind
;
1286 expr2
->expr_type
= EXPR_OP
;
1287 expr2
->where
= gfc_current_locus
;
1288 expr2
->value
.op
.op
= INTRINSIC_AND
;
1289 expr2
->value
.op
.op1
= expr
;
1290 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1294 block
->expr1
->value
.op
.op1
= expr
;
1296 /* 0 == size_expr */
1297 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1298 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1299 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1300 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1301 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1302 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1303 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1304 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1305 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1307 /* IF body: call final subroutine. */
1308 block
->next
= XCNEW (gfc_code
);
1309 block
->next
->op
= EXEC_CALL
;
1310 block
->next
->loc
= gfc_current_locus
;
1311 block
->next
->symtree
= fini
->proc_tree
;
1312 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1313 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1314 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1318 block
->block
= XCNEW (gfc_code
);
1319 block
= block
->block
;
1320 block
->loc
= gfc_current_locus
;
1321 block
->op
= EXEC_IF
;
1323 block
->next
= XCNEW (gfc_code
);
1324 block
= block
->next
;
1326 /* BLOCK ... END BLOCK. */
1327 block
->op
= EXEC_BLOCK
;
1328 block
->loc
= gfc_current_locus
;
1329 ns
= gfc_build_block_ns (sub_ns
);
1330 block
->ext
.block
.ns
= ns
;
1331 block
->ext
.block
.assoc
= NULL
;
1333 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1334 ptr2
->ts
.type
= BT_DERIVED
;
1335 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1336 ptr2
->attr
.flavor
= FL_VARIABLE
;
1337 ptr2
->attr
.pointer
= 1;
1338 ptr2
->attr
.artificial
= 1;
1339 gfc_set_sym_referenced (ptr2
);
1340 gfc_commit_symbol (ptr2
);
1342 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1343 tmp_array
->ts
.type
= BT_DERIVED
;
1344 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1345 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1346 tmp_array
->attr
.dimension
= 1;
1347 tmp_array
->attr
.artificial
= 1;
1348 tmp_array
->as
= gfc_get_array_spec();
1349 tmp_array
->attr
.intent
= INTENT_INOUT
;
1350 tmp_array
->as
->type
= AS_EXPLICIT
;
1351 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1353 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1355 gfc_expr
*shape_expr
;
1356 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1358 /* SIZE (array, dim=i+1, kind=default_kind). */
1359 shape_expr
= gfc_get_expr ();
1360 shape_expr
->expr_type
= EXPR_FUNCTION
;
1361 shape_expr
->value
.function
.isym
1362 = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE
);
1363 shape_expr
->symtree
= size_intr
;
1364 shape_expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1365 shape_expr
->value
.function
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1366 shape_expr
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1367 shape_expr
->value
.function
.actual
->next
->expr
1368 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
+1);
1369 shape_expr
->value
.function
.actual
->next
->next
= gfc_get_actual_arglist ();
1370 shape_expr
->value
.function
.actual
->next
->next
->expr
1371 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1372 shape_expr
->ts
= shape_expr
->value
.function
.isym
->ts
;
1374 tmp_array
->as
->upper
[i
] = shape_expr
;
1376 gfc_set_sym_referenced (tmp_array
);
1377 gfc_commit_symbol (tmp_array
);
1380 iter
= gfc_get_iterator ();
1381 iter
->var
= gfc_lval_expr_from_sym (idx
);
1382 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1383 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1384 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1386 block
= XCNEW (gfc_code
);
1388 block
->op
= EXEC_DO
;
1389 block
->loc
= gfc_current_locus
;
1390 block
->ext
.iterator
= iter
;
1391 block
->block
= gfc_get_code ();
1392 block
->block
->op
= EXEC_DO
;
1394 /* Offset calculation for the new array: idx * size of type (in bytes). */
1395 offset2
= gfc_get_expr ();
1396 offset2
= block
->ext
.actual
->expr
;
1397 offset2
->expr_type
= EXPR_OP
;
1398 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1399 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1400 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1401 offset2
->ts
= byte_stride
->ts
;
1403 /* Offset calculation of "array". */
1404 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1405 byte_stride
, rank
, block
->block
, sub_ns
);
1408 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1409 + idx * stride, c_ptr), ptr). */
1410 block2
->next
= finalization_scalarizer (array
, ptr
,
1411 gfc_lval_expr_from_sym (offset
),
1413 block2
= block2
->next
;
1414 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1417 block2
->next
= XCNEW (gfc_code
);
1418 block2
->next
->op
= EXEC_ASSIGN
;
1419 block2
->next
->loc
= gfc_current_locus
;
1420 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1421 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr
);
1423 /* Call now the user's final subroutine. */
1424 block
->next
= XCNEW (gfc_code
);
1425 block
= block
->next
;
1426 block
->op
= EXEC_CALL
;
1427 block
->loc
= gfc_current_locus
;
1428 block
->symtree
= fini
->proc_tree
;
1429 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1430 block
->ext
.actual
= gfc_get_actual_arglist ();
1431 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1433 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1439 iter
= gfc_get_iterator ();
1440 iter
->var
= gfc_lval_expr_from_sym (idx
);
1441 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1442 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1443 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1445 block
->next
= XCNEW (gfc_code
);
1446 block
= block
->next
;
1447 block
->op
= EXEC_DO
;
1448 block
->loc
= gfc_current_locus
;
1449 block
->ext
.iterator
= iter
;
1450 block
->block
= gfc_get_code ();
1451 block
->block
->op
= EXEC_DO
;
1453 /* Offset calculation of "array". */
1454 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1455 byte_stride
, rank
, block
->block
, sub_ns
);
1458 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1459 + offset, c_ptr), ptr). */
1460 block2
->next
= finalization_scalarizer (array
, ptr
,
1461 gfc_lval_expr_from_sym (offset
),
1463 block2
= block2
->next
;
1464 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1465 block2
= block2
->next
;
1468 block2
->next
= XCNEW (gfc_code
);
1469 block2
->next
->op
= EXEC_ASSIGN
;
1470 block2
->next
->loc
= gfc_current_locus
;
1471 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1472 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1476 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1477 derived type "derived". The function first calls the approriate FINAL
1478 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1479 components (but not the inherited ones). Last, it calls the wrapper
1480 subroutine of the parent. The generated wrapper procedure takes as argument
1481 an assumed-rank array.
1482 If neither allocatable components nor FINAL subroutines exists, the vtab
1483 will contain a NULL pointer.
1484 The generated function has the form
1485 _final(assumed-rank array, stride, skip_corarray)
1486 where the array has to be contiguous (except of the lowest dimension). The
1487 stride (in bytes) is used to allow different sizes for ancestor types by
1488 skipping over the additionally added components in the scalarizer. If
1489 "fini_coarray" is false, coarray components are not finalized to allow for
1490 the correct semantic with intrinsic assignment. */
1493 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1494 const char *tname
, gfc_component
*vtab_final
)
1496 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1497 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1498 gfc_symtree
*size_intr
;
1499 gfc_component
*comp
;
1500 gfc_namespace
*sub_ns
;
1501 gfc_code
*last_code
, *block
;
1502 char name
[GFC_MAX_SYMBOL_LEN
+1];
1503 bool finalizable_comp
= false;
1504 bool expr_null_wrapper
= false;
1505 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1508 /* Search for the ancestor's finalizers. */
1509 if (derived
->attr
.extension
&& derived
->components
1510 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1511 || has_finalizer_component (derived
)))
1514 gfc_component
*comp
;
1516 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1517 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1518 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1520 ancestor_wrapper
= comp
->initializer
;
1525 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1526 components: Return a NULL() expression; we defer this a bit to have have
1527 an interface declaration. */
1528 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1529 && !derived
->attr
.alloc_comp
1530 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1531 && !has_finalizer_component (derived
))
1532 expr_null_wrapper
= true;
1534 /* Check whether there are new allocatable components. */
1535 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1537 if (comp
== derived
->components
&& derived
->attr
.extension
1538 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1541 if (comp
->ts
.type
!= BT_CLASS
&& !comp
->attr
.pointer
1542 && (comp
->attr
.allocatable
1543 || (comp
->ts
.type
== BT_DERIVED
1544 && (comp
->ts
.u
.derived
->attr
.alloc_comp
1545 || has_finalizer_component (comp
->ts
.u
.derived
)
1546 || (comp
->ts
.u
.derived
->f2k_derived
1547 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))))
1548 finalizable_comp
= true;
1549 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1550 && CLASS_DATA (comp
)->attr
.allocatable
)
1551 finalizable_comp
= true;
1554 /* If there is no new finalizer and no new allocatable, return with
1555 an expr to the ancestor's one. */
1556 if (!expr_null_wrapper
&& !finalizable_comp
1557 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1559 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1560 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1561 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1562 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1566 /* We now create a wrapper, which does the following:
1567 1. Call the suitable finalization subroutine for this type
1568 2. Loop over all noninherited allocatable components and noninherited
1569 components with allocatable components and DEALLOCATE those; this will
1570 take care of finalizers, coarray deregistering and allocatable
1572 3. Call the ancestor's finalizer. */
1574 /* Declare the wrapper function; it takes an assumed-rank array
1575 and a VALUE logical as arguments. */
1577 /* Set up the namespace. */
1578 sub_ns
= gfc_get_namespace (ns
, 0);
1579 sub_ns
->sibling
= ns
->contained
;
1580 if (!expr_null_wrapper
)
1581 ns
->contained
= sub_ns
;
1582 sub_ns
->resolved
= 1;
1584 /* Set up the procedure symbol. */
1585 sprintf (name
, "__final_%s", tname
);
1586 gfc_get_symbol (name
, sub_ns
, &final
);
1587 sub_ns
->proc_name
= final
;
1588 final
->attr
.flavor
= FL_PROCEDURE
;
1589 final
->attr
.function
= 1;
1590 final
->attr
.pure
= 0;
1591 final
->result
= final
;
1592 final
->ts
.type
= BT_INTEGER
;
1594 final
->attr
.artificial
= 1;
1595 final
->attr
.if_source
= expr_null_wrapper
? IFSRC_IFBODY
: IFSRC_DECL
;
1596 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1597 final
->module
= ns
->proc_name
->name
;
1598 gfc_set_sym_referenced (final
);
1599 gfc_commit_symbol (final
);
1601 /* Set up formal argument. */
1602 gfc_get_symbol ("array", sub_ns
, &array
);
1603 array
->ts
.type
= BT_DERIVED
;
1604 array
->ts
.u
.derived
= derived
;
1605 array
->attr
.flavor
= FL_VARIABLE
;
1606 array
->attr
.dummy
= 1;
1607 array
->attr
.contiguous
= 1;
1608 array
->attr
.dimension
= 1;
1609 array
->attr
.artificial
= 1;
1610 array
->as
= gfc_get_array_spec();
1611 array
->as
->type
= AS_ASSUMED_RANK
;
1612 array
->as
->rank
= -1;
1613 array
->attr
.intent
= INTENT_INOUT
;
1614 gfc_set_sym_referenced (array
);
1615 final
->formal
= gfc_get_formal_arglist ();
1616 final
->formal
->sym
= array
;
1617 gfc_commit_symbol (array
);
1619 /* Set up formal argument. */
1620 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1621 byte_stride
->ts
.type
= BT_INTEGER
;
1622 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1623 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1624 byte_stride
->attr
.dummy
= 1;
1625 byte_stride
->attr
.value
= 1;
1626 byte_stride
->attr
.artificial
= 1;
1627 gfc_set_sym_referenced (byte_stride
);
1628 final
->formal
->next
= gfc_get_formal_arglist ();
1629 final
->formal
->next
->sym
= byte_stride
;
1630 gfc_commit_symbol (byte_stride
);
1632 /* Set up formal argument. */
1633 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1634 fini_coarray
->ts
.type
= BT_LOGICAL
;
1635 fini_coarray
->ts
.kind
= 1;
1636 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1637 fini_coarray
->attr
.dummy
= 1;
1638 fini_coarray
->attr
.value
= 1;
1639 fini_coarray
->attr
.artificial
= 1;
1640 gfc_set_sym_referenced (fini_coarray
);
1641 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1642 final
->formal
->next
->next
->sym
= fini_coarray
;
1643 gfc_commit_symbol (fini_coarray
);
1645 /* Return with a NULL() expression but with an interface which has
1646 the formal arguments. */
1647 if (expr_null_wrapper
)
1649 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1650 vtab_final
->ts
.interface
= final
;
1654 /* Local variables. */
1656 gfc_get_symbol ("idx", sub_ns
, &idx
);
1657 idx
->ts
.type
= BT_INTEGER
;
1658 idx
->ts
.kind
= gfc_index_integer_kind
;
1659 idx
->attr
.flavor
= FL_VARIABLE
;
1660 idx
->attr
.artificial
= 1;
1661 gfc_set_sym_referenced (idx
);
1662 gfc_commit_symbol (idx
);
1664 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1665 idx2
->ts
.type
= BT_INTEGER
;
1666 idx2
->ts
.kind
= gfc_index_integer_kind
;
1667 idx2
->attr
.flavor
= FL_VARIABLE
;
1668 idx2
->attr
.artificial
= 1;
1669 gfc_set_sym_referenced (idx2
);
1670 gfc_commit_symbol (idx2
);
1672 gfc_get_symbol ("offset", sub_ns
, &offset
);
1673 offset
->ts
.type
= BT_INTEGER
;
1674 offset
->ts
.kind
= gfc_index_integer_kind
;
1675 offset
->attr
.flavor
= FL_VARIABLE
;
1676 offset
->attr
.artificial
= 1;
1677 gfc_set_sym_referenced (offset
);
1678 gfc_commit_symbol (offset
);
1680 /* Create RANK expression. */
1681 rank
= gfc_get_expr ();
1682 rank
->expr_type
= EXPR_FUNCTION
;
1683 rank
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_RANK
);
1684 gfc_get_sym_tree ("rank", sub_ns
, &rank
->symtree
, false);
1685 rank
->symtree
->n
.sym
->intmod_sym_id
= GFC_ISYM_RANK
;
1686 rank
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1687 rank
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1688 gfc_commit_symbol (rank
->symtree
->n
.sym
);
1689 rank
->value
.function
.actual
= gfc_get_actual_arglist ();
1690 rank
->value
.function
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1691 rank
->ts
= rank
->value
.function
.isym
->ts
;
1692 gfc_convert_type (rank
, &idx
->ts
, 2);
1694 /* Create is_contiguous variable. */
1695 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1696 is_contiguous
->ts
.type
= BT_LOGICAL
;
1697 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1698 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1699 is_contiguous
->attr
.artificial
= 1;
1700 gfc_set_sym_referenced (is_contiguous
);
1701 gfc_commit_symbol (is_contiguous
);
1703 /* Create "sizes(0..rank)" variable, which contains the multiplied
1704 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1705 sizes(2) = sizes(1) * extent(dim=2) etc. */
1706 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1707 sizes
->ts
.type
= BT_INTEGER
;
1708 sizes
->ts
.kind
= gfc_index_integer_kind
;
1709 sizes
->attr
.flavor
= FL_VARIABLE
;
1710 sizes
->attr
.dimension
= 1;
1711 sizes
->attr
.artificial
= 1;
1712 sizes
->as
= gfc_get_array_spec();
1713 sizes
->attr
.intent
= INTENT_INOUT
;
1714 sizes
->as
->type
= AS_EXPLICIT
;
1715 sizes
->as
->rank
= 1;
1716 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1717 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1718 gfc_set_sym_referenced (sizes
);
1719 gfc_commit_symbol (sizes
);
1721 /* Create "strides(1..rank)" variable, which contains the strides per
1723 gfc_get_symbol ("strides", sub_ns
, &strides
);
1724 strides
->ts
.type
= BT_INTEGER
;
1725 strides
->ts
.kind
= gfc_index_integer_kind
;
1726 strides
->attr
.flavor
= FL_VARIABLE
;
1727 strides
->attr
.dimension
= 1;
1728 strides
->attr
.artificial
= 1;
1729 strides
->as
= gfc_get_array_spec();
1730 strides
->attr
.intent
= INTENT_INOUT
;
1731 strides
->as
->type
= AS_EXPLICIT
;
1732 strides
->as
->rank
= 1;
1733 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1734 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1735 gfc_set_sym_referenced (strides
);
1736 gfc_commit_symbol (strides
);
1739 /* Set return value to 0. */
1740 last_code
= XCNEW (gfc_code
);
1741 last_code
->op
= EXEC_ASSIGN
;
1742 last_code
->loc
= gfc_current_locus
;
1743 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1744 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1745 sub_ns
->code
= last_code
;
1747 /* Set: is_contiguous = .true. */
1748 last_code
->next
= XCNEW (gfc_code
);
1749 last_code
= last_code
->next
;
1750 last_code
->op
= EXEC_ASSIGN
;
1751 last_code
->loc
= gfc_current_locus
;
1752 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1753 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1754 &gfc_current_locus
, true);
1756 /* Set: sizes(0) = 1. */
1757 last_code
->next
= XCNEW (gfc_code
);
1758 last_code
= last_code
->next
;
1759 last_code
->op
= EXEC_ASSIGN
;
1760 last_code
->loc
= gfc_current_locus
;
1761 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1762 last_code
->expr1
->ref
= gfc_get_ref ();
1763 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1764 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1765 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1766 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1767 last_code
->expr1
->ref
->u
.ar
.start
[0]
1768 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1769 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1770 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1774 strides(idx) = _F._stride (array, dim=idx)
1775 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1776 if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
1780 iter
= gfc_get_iterator ();
1781 iter
->var
= gfc_lval_expr_from_sym (idx
);
1782 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1783 iter
->end
= gfc_copy_expr (rank
);
1784 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1785 last_code
->next
= XCNEW (gfc_code
);
1786 last_code
= last_code
->next
;
1787 last_code
->op
= EXEC_DO
;
1788 last_code
->loc
= gfc_current_locus
;
1789 last_code
->ext
.iterator
= iter
;
1790 last_code
->block
= gfc_get_code ();
1791 last_code
->block
->op
= EXEC_DO
;
1793 /* strides(idx) = _F._stride(array,dim=idx). */
1794 last_code
->block
->next
= XCNEW (gfc_code
);
1795 block
= last_code
->block
->next
;
1796 block
->op
= EXEC_ASSIGN
;
1797 block
->loc
= gfc_current_locus
;
1799 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1800 block
->expr1
->ref
= gfc_get_ref ();
1801 block
->expr1
->ref
->type
= REF_ARRAY
;
1802 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1803 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1804 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1805 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1806 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1808 block
->expr2
= gfc_get_expr ();
1809 block
->expr2
->expr_type
= EXPR_FUNCTION
;
1810 block
->expr2
->value
.function
.isym
1811 = gfc_intrinsic_function_by_id (GFC_ISYM_STRIDE
);
1812 gfc_get_sym_tree (GFC_PREFIX ("stride"), sub_ns
,
1813 &block
->expr2
->symtree
, false);
1814 block
->expr2
->symtree
->n
.sym
->intmod_sym_id
= GFC_ISYM_STRIDE
;
1815 block
->expr2
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1816 block
->expr2
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1817 gfc_commit_symbol (block
->expr2
->symtree
->n
.sym
);
1818 block
->expr2
->value
.function
.actual
= gfc_get_actual_arglist ();
1819 block
->expr2
->value
.function
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1821 block
->expr2
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1822 block
->expr2
->value
.function
.actual
->next
->expr
1823 = gfc_lval_expr_from_sym (idx
);
1824 block
->expr2
->ts
= block
->expr2
->value
.function
.isym
->ts
;
1826 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1827 block
->next
= XCNEW (gfc_code
);
1828 block
= block
->next
;
1829 block
->op
= EXEC_ASSIGN
;
1830 block
->loc
= gfc_current_locus
;
1832 /* sizes(idx) = ... */
1833 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1834 block
->expr1
->ref
= gfc_get_ref ();
1835 block
->expr1
->ref
->type
= REF_ARRAY
;
1836 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1837 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1838 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1839 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1840 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1842 block
->expr2
= gfc_get_expr ();
1843 block
->expr2
->expr_type
= EXPR_OP
;
1844 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1847 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1848 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1849 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1850 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1851 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1852 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1853 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1854 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1855 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1856 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1857 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1858 = gfc_lval_expr_from_sym (idx
);
1859 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1860 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1861 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1862 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1864 /* size(array, dim=idx, kind=index_kind). */
1865 block
->expr2
->value
.op
.op2
= gfc_get_expr ();
1866 block
->expr2
->value
.op
.op2
->expr_type
= EXPR_FUNCTION
;
1867 block
->expr2
->value
.op
.op2
->value
.function
.isym
1868 = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE
);
1869 gfc_get_sym_tree ("size", sub_ns
, &block
->expr2
->value
.op
.op2
->symtree
,
1871 size_intr
= block
->expr2
->value
.op
.op2
->symtree
;
1872 block
->expr2
->value
.op
.op2
->symtree
->n
.sym
->intmod_sym_id
= GFC_ISYM_SIZE
;
1873 block
->expr2
->value
.op
.op2
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1874 block
->expr2
->value
.op
.op2
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1875 gfc_commit_symbol (block
->expr2
->value
.op
.op2
->symtree
->n
.sym
);
1876 block
->expr2
->value
.op
.op2
->value
.function
.actual
1877 = gfc_get_actual_arglist ();
1878 block
->expr2
->value
.op
.op2
->value
.function
.actual
->expr
1879 = gfc_lval_expr_from_sym (array
);
1881 block
->expr2
->value
.op
.op2
->value
.function
.actual
->next
1882 = gfc_get_actual_arglist ();
1883 block
->expr2
->value
.op
.op2
->value
.function
.actual
->next
->expr
1884 = gfc_lval_expr_from_sym (idx
);
1885 /* kind=c_intptr_t. */
1886 block
->expr2
->value
.op
.op2
->value
.function
.actual
->next
->next
1887 = gfc_get_actual_arglist ();
1888 block
->expr2
->value
.op
.op2
->value
.function
.actual
->next
->next
->expr
1889 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1890 block
->expr2
->value
.op
.op2
->ts
= idx
->ts
;
1891 block
->expr2
->ts
= idx
->ts
;
1893 /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
1894 block
->next
= XCNEW (gfc_code
);
1895 block
= block
->next
;
1896 block
->loc
= gfc_current_locus
;
1897 block
->op
= EXEC_IF
;
1899 block
->block
= XCNEW (gfc_code
);
1900 block
= block
->block
;
1901 block
->loc
= gfc_current_locus
;
1902 block
->op
= EXEC_IF
;
1904 /* if condition: strides(idx) /= sizes(idx-1). */
1905 block
->expr1
= gfc_get_expr ();
1906 block
->expr1
->ts
.type
= BT_LOGICAL
;
1907 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1908 block
->expr1
->expr_type
= EXPR_OP
;
1909 block
->expr1
->where
= gfc_current_locus
;
1910 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1912 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1913 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1914 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1915 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1916 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1917 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1918 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1919 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1921 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1922 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1923 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1924 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1925 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1926 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1927 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1928 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1929 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1930 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1931 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1932 = gfc_lval_expr_from_sym (idx
);
1933 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1934 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1935 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1936 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1938 /* if body: is_contiguous = .false. */
1939 block
->next
= XCNEW (gfc_code
);
1940 block
= block
->next
;
1941 block
->op
= EXEC_ASSIGN
;
1942 block
->loc
= gfc_current_locus
;
1943 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1944 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1945 &gfc_current_locus
, false);
1947 /* Obtain the size (number of elements) of "array" MINUS ONE,
1948 which is used in the scalarization. */
1949 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
1950 nelem
->ts
.type
= BT_INTEGER
;
1951 nelem
->ts
.kind
= gfc_index_integer_kind
;
1952 nelem
->attr
.flavor
= FL_VARIABLE
;
1953 nelem
->attr
.artificial
= 1;
1954 gfc_set_sym_referenced (nelem
);
1955 gfc_commit_symbol (nelem
);
1957 /* nelem = sizes (rank) - 1. */
1958 last_code
->next
= XCNEW (gfc_code
);
1959 last_code
= last_code
->next
;
1960 last_code
->op
= EXEC_ASSIGN
;
1961 last_code
->loc
= gfc_current_locus
;
1963 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
1965 last_code
->expr2
= gfc_get_expr ();
1966 last_code
->expr2
->expr_type
= EXPR_OP
;
1967 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
1968 last_code
->expr2
->value
.op
.op2
1969 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1970 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
1972 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1973 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1974 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1975 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1976 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1977 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1978 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
1979 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1981 /* Call final subroutines. We now generate code like:
1983 integer, pointer :: ptr
1985 integer(c_intptr_t) :: i, addr
1987 select case (rank (array))
1989 ! If needed, the array is packed
1990 call final_rank3 (array)
1992 do i = 0, size (array)-1
1993 addr = transfer (c_loc (array), addr) + i * stride
1994 call c_f_pointer (transfer (addr, cptr), ptr)
1995 call elemental_final (ptr)
1999 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2001 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2003 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2004 ptr
->ts
.type
= BT_DERIVED
;
2005 ptr
->ts
.u
.derived
= derived
;
2006 ptr
->attr
.flavor
= FL_VARIABLE
;
2007 ptr
->attr
.pointer
= 1;
2008 ptr
->attr
.artificial
= 1;
2009 gfc_set_sym_referenced (ptr
);
2010 gfc_commit_symbol (ptr
);
2012 /* SELECT CASE (RANK (array)). */
2013 last_code
->next
= XCNEW (gfc_code
);
2014 last_code
= last_code
->next
;
2015 last_code
->op
= EXEC_SELECT
;
2016 last_code
->loc
= gfc_current_locus
;
2017 last_code
->expr1
= gfc_copy_expr (rank
);
2020 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
2022 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2028 /* CASE (fini_rank). */
2031 block
->block
= XCNEW (gfc_code
);
2032 block
= block
->block
;
2036 block
= XCNEW (gfc_code
);
2037 last_code
->block
= block
;
2039 block
->loc
= gfc_current_locus
;
2040 block
->op
= EXEC_SELECT
;
2041 block
->ext
.block
.case_list
= gfc_get_case ();
2042 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2043 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2044 block
->ext
.block
.case_list
->low
2045 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2046 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2048 block
->ext
.block
.case_list
->low
2049 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2050 block
->ext
.block
.case_list
->high
2051 = block
->ext
.block
.case_list
->low
;
2053 /* CALL fini_rank (array) - possibly with packing. */
2054 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2055 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2056 idx
, ptr
, nelem
, size_intr
, strides
,
2057 sizes
, idx2
, offset
, is_contiguous
,
2061 block
->next
= XCNEW (gfc_code
);
2062 block
->next
->op
= EXEC_CALL
;
2063 block
->next
->loc
= gfc_current_locus
;
2064 block
->next
->symtree
= fini
->proc_tree
;
2065 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2066 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2067 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2071 /* Elemental call - scalarized. */
2077 block
->block
= XCNEW (gfc_code
);
2078 block
= block
->block
;
2082 block
= XCNEW (gfc_code
);
2083 last_code
->block
= block
;
2085 block
->loc
= gfc_current_locus
;
2086 block
->op
= EXEC_SELECT
;
2087 block
->ext
.block
.case_list
= gfc_get_case ();
2090 iter
= gfc_get_iterator ();
2091 iter
->var
= gfc_lval_expr_from_sym (idx
);
2092 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2093 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2094 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2095 block
->next
= XCNEW (gfc_code
);
2096 block
= block
->next
;
2097 block
->op
= EXEC_DO
;
2098 block
->loc
= gfc_current_locus
;
2099 block
->ext
.iterator
= iter
;
2100 block
->block
= gfc_get_code ();
2101 block
->block
->op
= EXEC_DO
;
2103 /* Offset calculation. */
2104 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2105 byte_stride
, rank
, block
->block
,
2109 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2110 + offset, c_ptr), ptr). */
2112 = finalization_scalarizer (array
, ptr
,
2113 gfc_lval_expr_from_sym (offset
),
2115 block
= block
->next
;
2117 /* CALL final_elemental (array). */
2118 block
->next
= XCNEW (gfc_code
);
2119 block
= block
->next
;
2120 block
->op
= EXEC_CALL
;
2121 block
->loc
= gfc_current_locus
;
2122 block
->symtree
= fini_elem
->proc_tree
;
2123 block
->resolved_sym
= fini_elem
->proc_sym
;
2124 block
->ext
.actual
= gfc_get_actual_arglist ();
2125 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2129 /* Finalize and deallocate allocatable components. The same manual
2130 scalarization is used as above. */
2132 if (finalizable_comp
)
2135 gfc_code
*block
= NULL
;
2139 gfc_get_symbol ("ptr", sub_ns
, &ptr
);
2140 ptr
->ts
.type
= BT_DERIVED
;
2141 ptr
->ts
.u
.derived
= derived
;
2142 ptr
->attr
.flavor
= FL_VARIABLE
;
2143 ptr
->attr
.pointer
= 1;
2144 ptr
->attr
.artificial
= 1;
2145 gfc_set_sym_referenced (ptr
);
2146 gfc_commit_symbol (ptr
);
2149 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2150 stat
->attr
.flavor
= FL_VARIABLE
;
2151 stat
->attr
.artificial
= 1;
2152 stat
->ts
.type
= BT_INTEGER
;
2153 stat
->ts
.kind
= gfc_default_integer_kind
;
2154 gfc_set_sym_referenced (stat
);
2155 gfc_commit_symbol (stat
);
2158 iter
= gfc_get_iterator ();
2159 iter
->var
= gfc_lval_expr_from_sym (idx
);
2160 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2161 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2162 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2163 last_code
->next
= XCNEW (gfc_code
);
2164 last_code
= last_code
->next
;
2165 last_code
->op
= EXEC_DO
;
2166 last_code
->loc
= gfc_current_locus
;
2167 last_code
->ext
.iterator
= iter
;
2168 last_code
->block
= gfc_get_code ();
2169 last_code
->block
->op
= EXEC_DO
;
2171 /* Offset calculation. */
2172 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2173 byte_stride
, rank
, last_code
->block
,
2177 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2178 + idx * stride, c_ptr), ptr). */
2179 block
->next
= finalization_scalarizer (array
, ptr
,
2180 gfc_lval_expr_from_sym(offset
),
2182 block
= block
->next
;
2184 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2186 if (comp
== derived
->components
&& derived
->attr
.extension
2187 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2190 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2191 stat
, fini_coarray
, &block
);
2192 if (!last_code
->block
->next
)
2193 last_code
->block
->next
= block
;
2198 /* Call the finalizer of the ancestor. */
2199 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2201 last_code
->next
= XCNEW (gfc_code
);
2202 last_code
= last_code
->next
;
2203 last_code
->op
= EXEC_CALL
;
2204 last_code
->loc
= gfc_current_locus
;
2205 last_code
->symtree
= ancestor_wrapper
->symtree
;
2206 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2208 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2209 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2210 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2211 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2212 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2213 last_code
->ext
.actual
->next
->next
->expr
2214 = gfc_lval_expr_from_sym (fini_coarray
);
2217 gfc_free_expr (rank
);
2218 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2219 vtab_final
->ts
.interface
= final
;
2223 /* Add procedure pointers for all type-bound procedures to a vtab. */
2226 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2228 gfc_symbol
* super_type
;
2230 super_type
= gfc_get_derived_super_type (derived
);
2232 if (super_type
&& (super_type
!= derived
))
2234 /* Make sure that the PPCs appear in the same order as in the parent. */
2235 copy_vtab_proc_comps (super_type
, vtype
);
2236 /* Only needed to get the PPC initializers right. */
2237 add_procs_to_declared_vtab (super_type
, vtype
);
2240 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2241 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2243 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2244 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2248 /* Find or generate the symbol for a derived type's vtab. */
2251 gfc_find_derived_vtab (gfc_symbol
*derived
)
2254 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2255 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2257 /* Find the top-level namespace. */
2258 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2262 /* If the type is a class container, use the underlying derived type. */
2263 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2264 derived
= gfc_get_derived_super_type (derived
);
2268 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2270 get_unique_hashed_string (tname
, derived
);
2271 sprintf (name
, "__vtab_%s", tname
);
2273 /* Look for the vtab symbol in various namespaces. */
2274 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2276 gfc_find_symbol (name
, ns
, 0, &vtab
);
2278 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2282 gfc_get_symbol (name
, ns
, &vtab
);
2283 vtab
->ts
.type
= BT_DERIVED
;
2284 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2285 &gfc_current_locus
) == FAILURE
)
2287 vtab
->attr
.target
= 1;
2288 vtab
->attr
.save
= SAVE_IMPLICIT
;
2289 vtab
->attr
.vtab
= 1;
2290 vtab
->attr
.access
= ACCESS_PUBLIC
;
2291 gfc_set_sym_referenced (vtab
);
2292 sprintf (name
, "__vtype_%s", tname
);
2294 gfc_find_symbol (name
, ns
, 0, &vtype
);
2298 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2300 gfc_get_symbol (name
, ns
, &vtype
);
2301 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2302 NULL
, &gfc_current_locus
) == FAILURE
)
2304 vtype
->attr
.access
= ACCESS_PUBLIC
;
2305 vtype
->attr
.vtype
= 1;
2306 gfc_set_sym_referenced (vtype
);
2308 /* Add component '_hash'. */
2309 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2311 c
->ts
.type
= BT_INTEGER
;
2313 c
->attr
.access
= ACCESS_PRIVATE
;
2314 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2315 NULL
, derived
->hash_value
);
2317 /* Add component '_size'. */
2318 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2320 c
->ts
.type
= BT_INTEGER
;
2322 c
->attr
.access
= ACCESS_PRIVATE
;
2323 /* Remember the derived type in ts.u.derived,
2324 so that the correct initializer can be set later on
2325 (in gfc_conv_structure). */
2326 c
->ts
.u
.derived
= derived
;
2327 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2330 /* Add component _extends. */
2331 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2333 c
->attr
.pointer
= 1;
2334 c
->attr
.access
= ACCESS_PRIVATE
;
2335 if (!derived
->attr
.unlimited_polymorphic
)
2336 parent
= gfc_get_derived_super_type (derived
);
2342 parent_vtab
= gfc_find_derived_vtab (parent
);
2343 c
->ts
.type
= BT_DERIVED
;
2344 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2345 c
->initializer
= gfc_get_expr ();
2346 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2347 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2348 0, &c
->initializer
->symtree
);
2352 c
->ts
.type
= BT_DERIVED
;
2353 c
->ts
.u
.derived
= vtype
;
2354 c
->initializer
= gfc_get_null_expr (NULL
);
2357 if (!derived
->attr
.unlimited_polymorphic
2358 && derived
->components
== NULL
2359 && !derived
->attr
.zero_comp
)
2361 /* At this point an error must have occurred.
2362 Prevent further errors on the vtype components. */
2367 /* Add component _def_init. */
2368 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2370 c
->attr
.pointer
= 1;
2371 c
->attr
.artificial
= 1;
2372 c
->attr
.access
= ACCESS_PRIVATE
;
2373 c
->ts
.type
= BT_DERIVED
;
2374 c
->ts
.u
.derived
= derived
;
2375 if (derived
->attr
.unlimited_polymorphic
2376 || derived
->attr
.abstract
)
2377 c
->initializer
= gfc_get_null_expr (NULL
);
2380 /* Construct default initialization variable. */
2381 sprintf (name
, "__def_init_%s", tname
);
2382 gfc_get_symbol (name
, ns
, &def_init
);
2383 def_init
->attr
.target
= 1;
2384 def_init
->attr
.artificial
= 1;
2385 def_init
->attr
.save
= SAVE_IMPLICIT
;
2386 def_init
->attr
.access
= ACCESS_PUBLIC
;
2387 def_init
->attr
.flavor
= FL_VARIABLE
;
2388 gfc_set_sym_referenced (def_init
);
2389 def_init
->ts
.type
= BT_DERIVED
;
2390 def_init
->ts
.u
.derived
= derived
;
2391 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2393 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2396 /* Add component _copy. */
2397 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2399 c
->attr
.proc_pointer
= 1;
2400 c
->attr
.access
= ACCESS_PRIVATE
;
2401 c
->tb
= XCNEW (gfc_typebound_proc
);
2403 if (derived
->attr
.unlimited_polymorphic
2404 || derived
->attr
.abstract
)
2405 c
->initializer
= gfc_get_null_expr (NULL
);
2408 /* Set up namespace. */
2409 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2410 sub_ns
->sibling
= ns
->contained
;
2411 ns
->contained
= sub_ns
;
2412 sub_ns
->resolved
= 1;
2413 /* Set up procedure symbol. */
2414 sprintf (name
, "__copy_%s", tname
);
2415 gfc_get_symbol (name
, sub_ns
, ©
);
2416 sub_ns
->proc_name
= copy
;
2417 copy
->attr
.flavor
= FL_PROCEDURE
;
2418 copy
->attr
.subroutine
= 1;
2419 copy
->attr
.pure
= 1;
2420 copy
->attr
.artificial
= 1;
2421 copy
->attr
.if_source
= IFSRC_DECL
;
2422 /* This is elemental so that arrays are automatically
2423 treated correctly by the scalarizer. */
2424 copy
->attr
.elemental
= 1;
2425 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2426 copy
->module
= ns
->proc_name
->name
;
2427 gfc_set_sym_referenced (copy
);
2428 /* Set up formal arguments. */
2429 gfc_get_symbol ("src", sub_ns
, &src
);
2430 src
->ts
.type
= BT_DERIVED
;
2431 src
->ts
.u
.derived
= derived
;
2432 src
->attr
.flavor
= FL_VARIABLE
;
2433 src
->attr
.dummy
= 1;
2434 src
->attr
.artificial
= 1;
2435 src
->attr
.intent
= INTENT_IN
;
2436 gfc_set_sym_referenced (src
);
2437 copy
->formal
= gfc_get_formal_arglist ();
2438 copy
->formal
->sym
= src
;
2439 gfc_get_symbol ("dst", sub_ns
, &dst
);
2440 dst
->ts
.type
= BT_DERIVED
;
2441 dst
->ts
.u
.derived
= derived
;
2442 dst
->attr
.flavor
= FL_VARIABLE
;
2443 dst
->attr
.dummy
= 1;
2444 dst
->attr
.artificial
= 1;
2445 dst
->attr
.intent
= INTENT_OUT
;
2446 gfc_set_sym_referenced (dst
);
2447 copy
->formal
->next
= gfc_get_formal_arglist ();
2448 copy
->formal
->next
->sym
= dst
;
2450 sub_ns
->code
= gfc_get_code ();
2451 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2452 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2453 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2454 /* Set initializer. */
2455 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2456 c
->ts
.interface
= copy
;
2459 /* Add component _final, which contains a procedure pointer to
2460 a wrapper which handles both the freeing of allocatable
2461 components and the calls to finalization subroutines.
2462 Note: The actual wrapper function can only be generated
2463 at resolution time. */
2464 /* FIXME: Enable ABI-breaking "_final" generation. */
2467 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2469 c
->attr
.proc_pointer
= 1;
2470 c
->attr
.access
= ACCESS_PRIVATE
;
2471 c
->tb
= XCNEW (gfc_typebound_proc
);
2473 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2476 /* Add procedure pointers for type-bound procedures. */
2477 if (!derived
->attr
.unlimited_polymorphic
)
2478 add_procs_to_declared_vtab (derived
, vtype
);
2482 vtab
->ts
.u
.derived
= vtype
;
2483 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2490 /* It is unexpected to have some symbols added at resolution or code
2491 generation time. We commit the changes in order to keep a clean state. */
2494 gfc_commit_symbol (vtab
);
2496 gfc_commit_symbol (vtype
);
2498 gfc_commit_symbol (def_init
);
2500 gfc_commit_symbol (copy
);
2502 gfc_commit_symbol (src
);
2504 gfc_commit_symbol (dst
);
2507 gfc_undo_symbols ();
2513 /* Check if a derived type is finalizable. That is the case if it
2514 (1) has a FINAL subroutine or
2515 (2) has a nonpointer nonallocatable component of finalizable type.
2516 If it is finalizable, return an expression containing the
2517 finalization wrapper. */
2520 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2525 /* (1) Check for FINAL subroutines. */
2526 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2529 /* (2) Check for components of finalizable type. */
2530 for (c
= derived
->components
; c
; c
= c
->next
)
2531 if (c
->ts
.type
== BT_DERIVED
2532 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2533 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2539 /* Make sure vtab is generated. */
2540 vtab
= gfc_find_derived_vtab (derived
);
2543 /* Return finalizer expression. */
2544 gfc_component
*final
;
2545 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2546 gcc_assert (strcmp (final
->name
, "_final") == 0);
2547 gcc_assert (final
->initializer
2548 && final
->initializer
->expr_type
!= EXPR_NULL
);
2549 *final_expr
= final
->initializer
;
2555 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2556 need to support unlimited polymorphism. */
2559 gfc_find_intrinsic_vtab (gfc_typespec
*ts
)
2562 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2563 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2566 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2568 gfc_error ("TODO: Deferred character length variable at %C cannot "
2569 "yet be associated with unlimited polymorphic entities");
2573 if (ts
->type
== BT_UNKNOWN
)
2576 /* Sometimes the typespec is passed from a single call. */
2577 if (ts
->type
== BT_DERIVED
)
2578 return gfc_find_derived_vtab (ts
->u
.derived
);
2580 /* Find the top-level namespace. */
2581 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2585 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
2586 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2587 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
2591 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
2593 if (ts
->type
== BT_CHARACTER
)
2594 sprintf (tname
, "%s_%d_%d", gfc_basic_typename (ts
->type
),
2597 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2599 sprintf (name
, "__vtab_%s", tname
);
2601 /* Look for the vtab symbol in various namespaces. */
2602 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2604 gfc_find_symbol (name
, ns
, 0, &vtab
);
2608 gfc_get_symbol (name
, ns
, &vtab
);
2609 vtab
->ts
.type
= BT_DERIVED
;
2610 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2611 &gfc_current_locus
) == FAILURE
)
2613 vtab
->attr
.target
= 1;
2614 vtab
->attr
.save
= SAVE_IMPLICIT
;
2615 vtab
->attr
.vtab
= 1;
2616 vtab
->attr
.access
= ACCESS_PUBLIC
;
2617 gfc_set_sym_referenced (vtab
);
2618 sprintf (name
, "__vtype_%s", tname
);
2620 gfc_find_symbol (name
, ns
, 0, &vtype
);
2625 gfc_namespace
*sub_ns
;
2626 gfc_namespace
*contained
;
2628 gfc_get_symbol (name
, ns
, &vtype
);
2629 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
2630 NULL
, &gfc_current_locus
) == FAILURE
)
2632 vtype
->attr
.access
= ACCESS_PUBLIC
;
2633 vtype
->attr
.vtype
= 1;
2634 gfc_set_sym_referenced (vtype
);
2636 /* Add component '_hash'. */
2637 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
2639 c
->ts
.type
= BT_INTEGER
;
2641 c
->attr
.access
= ACCESS_PRIVATE
;
2642 hash
= gfc_intrinsic_hash_value (ts
);
2643 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2646 /* Add component '_size'. */
2647 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
2649 c
->ts
.type
= BT_INTEGER
;
2651 c
->attr
.access
= ACCESS_PRIVATE
;
2652 if (ts
->type
== BT_CHARACTER
)
2653 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2654 NULL
, charlen
*ts
->kind
);
2656 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2659 /* Add component _extends. */
2660 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
2662 c
->attr
.pointer
= 1;
2663 c
->attr
.access
= ACCESS_PRIVATE
;
2664 c
->ts
.type
= BT_VOID
;
2665 c
->initializer
= gfc_get_null_expr (NULL
);
2667 /* Add component _def_init. */
2668 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
2670 c
->attr
.pointer
= 1;
2671 c
->attr
.access
= ACCESS_PRIVATE
;
2672 c
->ts
.type
= BT_VOID
;
2673 c
->initializer
= gfc_get_null_expr (NULL
);
2675 /* Add component _copy. */
2676 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
2678 c
->attr
.proc_pointer
= 1;
2679 c
->attr
.access
= ACCESS_PRIVATE
;
2680 c
->tb
= XCNEW (gfc_typebound_proc
);
2683 /* Check to see if copy function already exists. Note
2684 that this is only used for characters of different
2686 contained
= ns
->contained
;
2687 for (; contained
; contained
= contained
->sibling
)
2688 if (contained
->proc_name
2689 && strcmp (name
, contained
->proc_name
->name
) == 0)
2691 copy
= contained
->proc_name
;
2695 /* Set up namespace. */
2696 sub_ns
= gfc_get_namespace (ns
, 0);
2697 sub_ns
->sibling
= ns
->contained
;
2698 ns
->contained
= sub_ns
;
2699 sub_ns
->resolved
= 1;
2700 /* Set up procedure symbol. */
2701 if (ts
->type
!= BT_CHARACTER
)
2702 sprintf (name
, "__copy_%s", tname
);
2704 /* __copy is always the same for characters. */
2705 sprintf (name
, "__copy_character_%d", ts
->kind
);
2706 gfc_get_symbol (name
, sub_ns
, ©
);
2707 sub_ns
->proc_name
= copy
;
2708 copy
->attr
.flavor
= FL_PROCEDURE
;
2709 copy
->attr
.subroutine
= 1;
2710 copy
->attr
.pure
= 1;
2711 copy
->attr
.if_source
= IFSRC_DECL
;
2712 /* This is elemental so that arrays are automatically
2713 treated correctly by the scalarizer. */
2714 copy
->attr
.elemental
= 1;
2715 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2716 copy
->module
= ns
->proc_name
->name
;
2717 gfc_set_sym_referenced (copy
);
2718 /* Set up formal arguments. */
2719 gfc_get_symbol ("src", sub_ns
, &src
);
2720 src
->ts
.type
= ts
->type
;
2721 src
->ts
.kind
= ts
->kind
;
2722 src
->attr
.flavor
= FL_VARIABLE
;
2723 src
->attr
.dummy
= 1;
2724 src
->attr
.intent
= INTENT_IN
;
2725 gfc_set_sym_referenced (src
);
2726 copy
->formal
= gfc_get_formal_arglist ();
2727 copy
->formal
->sym
= src
;
2728 gfc_get_symbol ("dst", sub_ns
, &dst
);
2729 dst
->ts
.type
= ts
->type
;
2730 dst
->ts
.kind
= ts
->kind
;
2731 dst
->attr
.flavor
= FL_VARIABLE
;
2732 dst
->attr
.dummy
= 1;
2733 dst
->attr
.intent
= INTENT_OUT
;
2734 gfc_set_sym_referenced (dst
);
2735 copy
->formal
->next
= gfc_get_formal_arglist ();
2736 copy
->formal
->next
->sym
= dst
;
2738 sub_ns
->code
= gfc_get_code ();
2739 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
2740 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2741 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2743 /* Set initializer. */
2744 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2745 c
->ts
.interface
= copy
;
2747 /* Add component _final. */
2748 if (gfc_add_component (vtype
, "_final", &c
) == FAILURE
)
2750 c
->attr
.proc_pointer
= 1;
2751 c
->attr
.access
= ACCESS_PRIVATE
;
2752 c
->tb
= XCNEW (gfc_typebound_proc
);
2754 c
->initializer
= gfc_get_null_expr (NULL
);
2756 vtab
->ts
.u
.derived
= vtype
;
2757 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2764 /* It is unexpected to have some symbols added at resolution or code
2765 generation time. We commit the changes in order to keep a clean state. */
2768 gfc_commit_symbol (vtab
);
2770 gfc_commit_symbol (vtype
);
2772 gfc_commit_symbol (def_init
);
2774 gfc_commit_symbol (copy
);
2776 gfc_commit_symbol (src
);
2778 gfc_commit_symbol (dst
);
2781 gfc_undo_symbols ();
2787 /* General worker function to find either a type-bound procedure or a
2788 type-bound user operator. */
2791 find_typebound_proc_uop (gfc_symbol
* derived
, gfc_try
* t
,
2792 const char* name
, bool noaccess
, bool uop
,
2798 /* Set correct symbol-root. */
2799 gcc_assert (derived
->f2k_derived
);
2800 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2801 : derived
->f2k_derived
->tb_sym_root
);
2803 /* Set default to failure. */
2807 /* Try to find it in the current type's namespace. */
2808 res
= gfc_find_symtree (root
, name
);
2809 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2815 if (!noaccess
&& derived
->attr
.use_assoc
2816 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2819 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2820 name
, derived
->name
, where
);
2828 /* Otherwise, recurse on parent type if derived is an extension. */
2829 if (derived
->attr
.extension
)
2831 gfc_symbol
* super_type
;
2832 super_type
= gfc_get_derived_super_type (derived
);
2833 gcc_assert (super_type
);
2835 return find_typebound_proc_uop (super_type
, t
, name
,
2836 noaccess
, uop
, where
);
2839 /* Nothing found. */
2844 /* Find a type-bound procedure or user operator by name for a derived-type
2845 (looking recursively through the super-types). */
2848 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
2849 const char* name
, bool noaccess
, locus
* where
)
2851 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
2855 gfc_find_typebound_user_op (gfc_symbol
* derived
, gfc_try
* t
,
2856 const char* name
, bool noaccess
, locus
* where
)
2858 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
2862 /* Find a type-bound intrinsic operator looking recursively through the
2863 super-type hierarchy. */
2866 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_try
* t
,
2867 gfc_intrinsic_op op
, bool noaccess
,
2870 gfc_typebound_proc
* res
;
2872 /* Set default to failure. */
2876 /* Try to find it in the current type's namespace. */
2877 if (derived
->f2k_derived
)
2878 res
= derived
->f2k_derived
->tb_op
[op
];
2883 if (res
&& !res
->error
)
2889 if (!noaccess
&& derived
->attr
.use_assoc
2890 && res
->access
== ACCESS_PRIVATE
)
2893 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2894 gfc_op2string (op
), derived
->name
, where
);
2902 /* Otherwise, recurse on parent type if derived is an extension. */
2903 if (derived
->attr
.extension
)
2905 gfc_symbol
* super_type
;
2906 super_type
= gfc_get_derived_super_type (derived
);
2907 gcc_assert (super_type
);
2909 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
2913 /* Nothing found. */
2918 /* Get a typebound-procedure symtree or create and insert it if not yet
2919 present. This is like a very simplified version of gfc_get_sym_tree for
2920 tbp-symtrees rather than regular ones. */
2923 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
2925 gfc_symtree
*result
;
2927 result
= gfc_find_symtree (*root
, name
);
2930 result
= gfc_new_symtree (root
, name
);
2931 gcc_assert (result
);
2932 result
->n
.tb
= NULL
;