1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2023 Free Software Foundation, Inc.
3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 and Janus Weil <janus@gcc.gnu.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* class.cc -- This file contains the front end functions needed to service
24 the implementation of Fortran 2003 polymorphism and other
25 object-oriented features. */
28 /* Outline of the internal representation:
30 Each CLASS variable is encapsulated by a class container, which is a
31 structure with two fields:
32 * _data: A pointer to the actual data of the variable. This field has the
33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...).
35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
37 Only for unlimited polymorphic classes:
38 * _len: An integer(C_SIZE_T) to store the string length when the unlimited
39 polymorphic pointer is used to point to a char array. The '_len'
40 component will be zero when no character array is stored in
43 For each derived type we set up a "vtable" entry, i.e. a structure with the
45 * _hash: A hash value serving as a unique identifier for this type.
46 * _size: The size in bytes of the derived type.
47 * _extends: A pointer to the vtable entry of the parent derived type.
48 * _def_init: A pointer to a default initialized variable of this type.
49 * _copy: A procedure pointer to a copying procedure.
50 * _final: A procedure pointer to a wrapper function, which frees
51 allocatable components and calls FINAL subroutines.
52 * _deallocate: A procedure pointer to a deallocation procedure; nonnull
53 only for a recursive derived type.
55 After these follow procedure pointer components for the specific
56 type-bound procedures. */
61 #include "coretypes.h"
63 #include "constructor.h"
64 #include "target-memory.h"
66 /* Inserts a derived type component reference in a data reference chain.
67 TS: base type of the ref chain so far, in which we will pick the component
68 REF: the address of the GFC_REF pointer to update
69 NAME: name of the component to insert
70 Note that component insertion makes sense only if we are at the end of
71 the chain (*REF == NULL) or if we are adding a missing "_data" component
72 to access the actual contents of a class object. */
75 insert_component_ref (gfc_typespec
*ts
, gfc_ref
**ref
, const char * const name
)
80 gcc_assert (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
);
82 gfc_find_component (ts
->u
.derived
, name
, true, true, &new_ref
);
84 gfc_get_errors (&wcnt
, &ecnt
);
85 if (ecnt
> 0 && !new_ref
)
87 gcc_assert (new_ref
->u
.c
.component
);
90 new_ref
= new_ref
->next
;
97 /* We need to update the base type in the trailing reference chain to
98 that of the new component. */
100 gcc_assert (strcmp (name
, "_data") == 0);
102 if (new_ref
->next
->type
== REF_COMPONENT
)
103 next
= new_ref
->next
;
104 else if (new_ref
->next
->type
== REF_ARRAY
105 && new_ref
->next
->next
106 && new_ref
->next
->next
->type
== REF_COMPONENT
)
107 next
= new_ref
->next
->next
;
111 gcc_assert (new_ref
->u
.c
.component
->ts
.type
== BT_CLASS
112 || new_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
);
113 next
->u
.c
.sym
= new_ref
->u
.c
.component
->ts
.u
.derived
;
121 /* Tells whether we need to add a "_data" reference to access REF subobject
122 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
123 object accessed by REF is a variable; in other words it is a full object,
127 class_data_ref_missing (gfc_typespec
*ts
, gfc_ref
*ref
, bool first_ref_in_chain
)
129 /* Only class containers may need the "_data" reference. */
130 if (ts
->type
!= BT_CLASS
)
133 /* Accessing a class container with an array reference is certainly wrong. */
134 if (ref
->type
!= REF_COMPONENT
)
137 /* Accessing the class container's fields is fine. */
138 if (ref
->u
.c
.component
->name
[0] == '_')
141 /* At this point we have a class container with a non class container's field
142 component reference. We don't want to add the "_data" component if we are
143 at the first reference and the symbol's type is an extended derived type.
144 In that case, conv_parent_component_references will do the right thing so
145 it is not absolutely necessary. Omitting it prevents a regression (see
146 class_41.f03) in the interface mapping mechanism. When evaluating string
147 lengths depending on dummy arguments, we create a fake symbol with a type
148 equal to that of the dummy type. However, because of type extension,
149 the backend type (corresponding to the actual argument) can have a
150 different (extended) type. Adding the "_data" component explicitly, using
151 the base type, confuses the gfc_conv_component_ref code which deals with
152 the extended type. */
153 if (first_ref_in_chain
&& ts
->u
.derived
->attr
.extension
)
156 /* We have a class container with a non class container's field component
157 reference that doesn't fall into the above. */
162 /* Browse through a data reference chain and add the missing "_data" references
163 when a subobject of a class object is accessed without it.
164 Note that it doesn't add the "_data" reference when the class container
165 is the last element in the reference chain. */
168 gfc_fix_class_refs (gfc_expr
*e
)
173 if ((e
->expr_type
!= EXPR_VARIABLE
174 && e
->expr_type
!= EXPR_FUNCTION
)
175 || (e
->expr_type
== EXPR_FUNCTION
176 && e
->value
.function
.isym
!= NULL
))
179 if (e
->expr_type
== EXPR_VARIABLE
)
180 ts
= &e
->symtree
->n
.sym
->ts
;
185 gcc_assert (e
->expr_type
== EXPR_FUNCTION
);
186 if (e
->value
.function
.esym
!= NULL
)
187 func
= e
->value
.function
.esym
;
189 func
= e
->symtree
->n
.sym
;
191 if (func
->result
!= NULL
)
192 ts
= &func
->result
->ts
;
197 for (ref
= &e
->ref
; *ref
!= NULL
; ref
= &(*ref
)->next
)
199 if (class_data_ref_missing (ts
, *ref
, ref
== &e
->ref
))
200 insert_component_ref (ts
, ref
, "_data");
202 if ((*ref
)->type
== REF_COMPONENT
)
203 ts
= &(*ref
)->u
.c
.component
->ts
;
208 /* Insert a reference to the component of the given name.
209 Only to be used with CLASS containers and vtables. */
212 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
215 gfc_ref
**tail
= &(e
->ref
);
216 gfc_ref
*ref
, *next
= NULL
;
217 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
218 while (*tail
!= NULL
)
220 if ((*tail
)->type
== REF_COMPONENT
)
222 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
224 && (*tail
)->next
->type
== REF_ARRAY
225 && (*tail
)->next
->next
== NULL
)
227 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
229 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
231 tail
= &((*tail
)->next
);
233 if (derived
&& derived
->components
&& derived
->components
->next
&&
234 derived
->components
->next
->ts
.type
== BT_DERIVED
&&
235 derived
->components
->next
->ts
.u
.derived
== NULL
)
237 /* Fix up missing vtype. */
238 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
240 derived
->components
->next
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
242 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
245 /* Avoid losing memory. */
246 gfc_free_ref_list (*tail
);
247 c
= gfc_find_component (derived
, name
, true, true, tail
);
250 for (ref
= *tail
; ref
->next
; ref
= ref
->next
)
259 /* This is used to add both the _data component reference and an array
260 reference to class expressions. Used in translation of intrinsic
261 array inquiry functions. */
264 gfc_add_class_array_ref (gfc_expr
*e
)
266 int rank
= CLASS_DATA (e
)->as
->rank
;
267 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
269 gfc_add_data_component (e
);
271 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
274 if (ref
->type
!= REF_ARRAY
)
276 ref
->next
= gfc_get_ref ();
278 ref
->type
= REF_ARRAY
;
279 ref
->u
.ar
.type
= AR_FULL
;
285 /* Unfortunately, class array expressions can appear in various conditions;
286 with and without both _data component and an arrayspec. This function
287 deals with that variability. The previous reference to 'ref' is to a
291 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
293 bool no_data
= false;
294 bool with_data
= false;
296 /* An array reference with no _data component. */
297 if (ref
&& ref
->type
== REF_ARRAY
299 && ref
->u
.ar
.type
!= AR_ELEMENT
)
302 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
306 /* Cover cases where _data appears, with or without an array ref. */
307 if (ref
&& ref
->type
== REF_COMPONENT
308 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
316 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
317 && ref
->type
== REF_COMPONENT
318 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
322 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
326 return no_data
|| with_data
;
330 /* Returns true if the expression contains a reference to a class
331 array. Notice that class array elements return false. */
334 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
344 /* Is this a class array object? ie. Is the symbol of type class? */
346 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
347 && CLASS_DATA (e
->symtree
->n
.sym
)
348 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
349 && class_array_ref_detected (e
->ref
, full_array
))
352 /* Or is this a class array component reference? */
353 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
355 if (ref
->type
== REF_COMPONENT
356 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
357 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
358 && class_array_ref_detected (ref
->next
, full_array
))
366 /* Returns true if the expression is a reference to a class
367 scalar. This function is necessary because such expressions
368 can be dressed with a reference to the _data component and so
369 have a type other than BT_CLASS. */
372 gfc_is_class_scalar_expr (gfc_expr
*e
)
379 /* Is this a class object? */
381 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
382 && CLASS_DATA (e
->symtree
->n
.sym
)
383 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
385 || (e
->ref
->type
== REF_COMPONENT
386 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
387 && e
->ref
->next
== NULL
)))
390 /* Or is the final reference BT_CLASS or _data? */
391 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
393 if (ref
->type
== REF_COMPONENT
394 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
395 && CLASS_DATA (ref
->u
.c
.component
)
396 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
397 && (ref
->next
== NULL
398 || (ref
->next
->type
== REF_COMPONENT
399 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
400 && ref
->next
->next
== NULL
)))
408 /* Tells whether the expression E is a reference to a (scalar) class container.
409 Scalar because array class containers usually have an array reference after
410 them, and gfc_fix_class_refs will add the missing "_data" component reference
414 gfc_is_class_container_ref (gfc_expr
*e
)
419 if (e
->expr_type
!= EXPR_VARIABLE
)
420 return e
->ts
.type
== BT_CLASS
;
422 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
427 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
429 if (ref
->type
!= REF_COMPONENT
)
431 else if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
441 /* Build an initializer for CLASS pointers,
442 initializing the _data component to the init_expr (or NULL) and the _vptr
443 component to the corresponding type (or the declared type, given by ts). */
446 gfc_class_initializer (gfc_typespec
*ts
, gfc_expr
*init_expr
)
450 gfc_symbol
*vtab
= NULL
;
452 if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
453 vtab
= gfc_find_vtab (&init_expr
->ts
);
455 vtab
= gfc_find_vtab (ts
);
457 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
458 &ts
->u
.derived
->declared_at
);
461 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
463 gfc_constructor
*ctor
= gfc_constructor_get();
464 if (strcmp (comp
->name
, "_vptr") == 0 && vtab
)
465 ctor
->expr
= gfc_lval_expr_from_sym (vtab
);
466 else if (init_expr
&& init_expr
->expr_type
!= EXPR_NULL
)
467 ctor
->expr
= gfc_copy_expr (init_expr
);
469 ctor
->expr
= gfc_get_null_expr (NULL
);
470 gfc_constructor_append (&init
->value
.constructor
, ctor
);
477 /* Create a unique string identifier for a derived type, composed of its name
478 and module name. This is used to construct unique names for the class
479 containers and vtab symbols. */
482 get_unique_type_string (gfc_symbol
*derived
)
487 if (derived
->attr
.unlimited_polymorphic
)
490 dt_name
= gfc_dt_upper_string (derived
->name
);
491 len
= strlen (dt_name
) + 2;
492 if (derived
->attr
.unlimited_polymorphic
)
494 string
= XNEWVEC (char, len
);
495 sprintf (string
, "_%s", dt_name
);
497 else if (derived
->module
)
499 string
= XNEWVEC (char, strlen (derived
->module
) + len
);
500 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
502 else if (derived
->ns
->proc_name
)
504 string
= XNEWVEC (char, strlen (derived
->ns
->proc_name
->name
) + len
);
505 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
509 string
= XNEWVEC (char, len
);
510 sprintf (string
, "_%s", dt_name
);
516 /* A relative of 'get_unique_type_string' which makes sure the generated
517 string will not be too long (replacing it by a hash string if needed). */
520 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
522 /* Provide sufficient space to hold "symbol.symbol_symbol". */
524 tmp
= get_unique_type_string (derived
);
525 /* If string is too long, use hash value in hex representation (allow for
526 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
527 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
528 where %d is the (co)rank which can be up to n = 15. */
529 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
531 int h
= gfc_hash_value (derived
);
532 sprintf (string
, "%X", h
);
535 strcpy (string
, tmp
);
540 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
543 gfc_hash_value (gfc_symbol
*sym
)
545 unsigned int hash
= 0;
546 /* Provide sufficient space to hold "symbol.symbol_symbol". */
550 c
= get_unique_type_string (sym
);
553 for (i
= 0; i
< len
; i
++)
554 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
557 /* Return the hash but take the modulus for the sake of module read,
558 even though this slightly increases the chance of collision. */
559 return (hash
% 100000000);
563 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
566 gfc_intrinsic_hash_value (gfc_typespec
*ts
)
568 unsigned int hash
= 0;
569 const char *c
= gfc_typename (ts
, true);
574 for (i
= 0; i
< len
; i
++)
575 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
577 /* Return the hash but take the modulus for the sake of module read,
578 even though this slightly increases the chance of collision. */
579 return (hash
% 100000000);
583 /* Get the _len component from a class/derived object storing a string.
584 For unlimited polymorphic entities a ref to the _data component is available
585 while a ref to the _len component is needed. This routine traverese the
586 ref-chain and strips the last ref to a _data from it replacing it with a
587 ref to the _len component. */
590 gfc_get_len_component (gfc_expr
*e
, int k
)
593 gfc_ref
*ref
, **last
;
595 ptr
= gfc_copy_expr (e
);
597 /* We need to remove the last _data component ref from ptr. */
603 && ref
->type
== REF_COMPONENT
604 && strcmp ("_data", ref
->u
.c
.component
->name
)== 0)
606 gfc_free_ref_list (ref
);
613 /* And replace if with a ref to the _len component. */
614 gfc_add_len_component (ptr
);
615 if (k
!= ptr
->ts
.kind
)
619 ts
.type
= BT_INTEGER
;
621 gfc_convert_type_warn (ptr
, &ts
, 2, 0);
627 /* Build a polymorphic CLASS entity, using the symbol that comes from
628 build_sym. A CLASS entity is represented by an encapsulating type,
629 which contains the declared type as '_data' component, plus a pointer
630 component '_vptr' which determines the dynamic type. When this CLASS
631 entity is unlimited polymorphic, then also add a component '_len' to
632 store the length of string when that is stored in it. */
636 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
639 char tname
[GFC_MAX_SYMBOL_LEN
+1];
641 gfc_typespec
*orig_ts
= ts
;
650 /* Class container has already been built with same name. */
652 && ts
->u
.derived
->components
->attr
.dimension
>= attr
->dimension
653 && ts
->u
.derived
->components
->attr
.codimension
>= attr
->codimension
654 && ts
->u
.derived
->components
->attr
.class_pointer
>= attr
->pointer
655 && ts
->u
.derived
->components
->attr
.allocatable
>= attr
->allocatable
)
659 attr
->dimension
|= ts
->u
.derived
->components
->attr
.dimension
;
660 attr
->codimension
|= ts
->u
.derived
->components
->attr
.codimension
;
661 attr
->pointer
|= ts
->u
.derived
->components
->attr
.class_pointer
;
662 attr
->allocatable
|= ts
->u
.derived
->components
->attr
.allocatable
;
663 ts
= &ts
->u
.derived
->components
->ts
;
666 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
667 || attr
->select_type_temporary
|| attr
->associate_var
;
670 /* We cannot build the class container yet. */
673 /* Determine the name of the encapsulating type. */
674 rank
= !(*as
) || (*as
)->rank
== -1 ? GFC_MAX_DIMENSIONS
: (*as
)->rank
;
679 get_unique_hashed_string (tname
, ts
->u
.derived
);
680 if ((*as
) && attr
->allocatable
)
681 name
= xasprintf ("__class_%s_%d_%da", tname
, rank
, (*as
)->corank
);
682 else if ((*as
) && attr
->pointer
)
683 name
= xasprintf ("__class_%s_%d_%dp", tname
, rank
, (*as
)->corank
);
685 name
= xasprintf ("__class_%s_%d_%dt", tname
, rank
, (*as
)->corank
);
686 else if (attr
->pointer
)
687 name
= xasprintf ("__class_%s_p", tname
);
688 else if (attr
->allocatable
)
689 name
= xasprintf ("__class_%s_a", tname
);
691 name
= xasprintf ("__class_%s_t", tname
);
693 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
695 /* Find the top-level namespace. */
696 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
701 ns
= ts
->u
.derived
->ns
;
703 /* Although this might seem to be counterintuitive, we can build separate
704 class types with different array specs because the TKR interface checks
705 work on the declared type. All array type other than deferred shape or
706 assumed rank are added to the function namespace to ensure that they
707 are properly distinguished. */
708 if (attr
->dummy
&& !attr
->codimension
&& (*as
)
709 && !((*as
)->type
== AS_DEFERRED
|| (*as
)->type
== AS_ASSUMED_RANK
))
713 gfc_find_symbol (name
, ns
, 0, &fclass
);
714 /* If a local class type with this name already exists, update the
715 name with an index. */
719 sname
= xasprintf ("%s_%d", name
, ++ctr
);
725 gfc_find_symbol (name
, ns
, 0, &fclass
);
730 /* If not there, create a new symbol. */
731 fclass
= gfc_new_symbol (name
, ns
);
732 st
= gfc_new_symtree (&ns
->sym_root
, name
);
734 gfc_set_sym_referenced (fclass
);
736 fclass
->ts
.type
= BT_UNKNOWN
;
737 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
738 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
739 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
740 if (!gfc_add_flavor (&fclass
->attr
, FL_DERIVED
, NULL
,
744 /* Add component '_data'. */
745 if (!gfc_add_component (fclass
, "_data", &c
))
748 c
->ts
.type
= BT_DERIVED
;
749 c
->attr
.access
= ACCESS_PRIVATE
;
750 c
->ts
.u
.derived
= ts
->u
.derived
;
751 c
->attr
.class_pointer
= attr
->pointer
;
752 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
753 || attr
->select_type_temporary
;
754 c
->attr
.allocatable
= attr
->allocatable
;
755 c
->attr
.dimension
= attr
->dimension
;
756 c
->attr
.codimension
= attr
->codimension
;
757 c
->attr
.abstract
= fclass
->attr
.abstract
;
759 c
->initializer
= NULL
;
761 /* Add component '_vptr'. */
762 if (!gfc_add_component (fclass
, "_vptr", &c
))
764 c
->ts
.type
= BT_DERIVED
;
765 c
->attr
.access
= ACCESS_PRIVATE
;
768 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
770 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
772 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
774 /* Add component '_len'. Only unlimited polymorphic pointers may
775 have a string assigned to them, i.e., only those need the _len
777 if (!gfc_add_component (fclass
, "_len", &c
))
779 c
->ts
.type
= BT_INTEGER
;
780 c
->ts
.kind
= gfc_charlen_int_kind
;
781 c
->attr
.access
= ACCESS_PRIVATE
;
782 c
->attr
.artificial
= 1;
785 /* Build vtab later. */
786 c
->ts
.u
.derived
= NULL
;
789 if (!ts
->u
.derived
->attr
.unlimited_polymorphic
)
791 /* Since the extension field is 8 bit wide, we can only have
792 up to 255 extension levels. */
793 if (ts
->u
.derived
->attr
.extension
== 255)
795 gfc_error ("Maximum extension level reached with type %qs at %L",
796 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
800 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
801 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
802 fclass
->attr
.coarray_comp
= ts
->u
.derived
->attr
.coarray_comp
;
805 fclass
->attr
.is_class
= 1;
806 orig_ts
->u
.derived
= fclass
;
807 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
814 /* Add a procedure pointer component to the vtype
815 to represent a specific type-bound procedure. */
818 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
822 if (tb
->non_overridable
&& !tb
->overridden
)
825 c
= gfc_find_component (vtype
, name
, true, true, NULL
);
829 /* Add procedure component. */
830 if (!gfc_add_component (vtype
, name
, &c
))
834 c
->tb
= XCNEW (gfc_typebound_proc
);
837 c
->attr
.procedure
= 1;
838 c
->attr
.proc_pointer
= 1;
839 c
->attr
.flavor
= FL_PROCEDURE
;
840 c
->attr
.access
= ACCESS_PRIVATE
;
841 c
->attr
.external
= 1;
843 c
->attr
.if_source
= IFSRC_IFBODY
;
845 else if (c
->attr
.proc_pointer
&& c
->tb
)
853 gfc_symbol
*ifc
= tb
->u
.specific
->n
.sym
;
854 c
->ts
.interface
= ifc
;
856 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
857 c
->attr
.pure
= ifc
->attr
.pure
;
862 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
865 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
871 add_procs_to_declared_vtab1 (st
->left
, vtype
);
874 add_procs_to_declared_vtab1 (st
->right
, vtype
);
876 if (st
->n
.tb
&& !st
->n
.tb
->error
877 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
878 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
882 /* Copy procedure pointers components from the parent type. */
885 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
890 vtab
= gfc_find_derived_vtab (declared
);
892 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
894 if (gfc_find_component (vtype
, cmp
->name
, true, true, NULL
))
897 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
902 /* Returns true if any of its nonpointer nonallocatable components or
903 their nonpointer nonallocatable subcomponents has a finalization
907 has_finalizer_component (gfc_symbol
*derived
)
911 for (c
= derived
->components
; c
; c
= c
->next
)
912 if (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
&& !c
->attr
.allocatable
)
914 if (c
->ts
.u
.derived
->f2k_derived
915 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
918 /* Stop infinite recursion through this function by inhibiting
919 calls when the derived type and that of the component are
921 if (!gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)
922 && has_finalizer_component (c
->ts
.u
.derived
))
930 comp_is_finalizable (gfc_component
*comp
)
932 if (comp
->attr
.proc_pointer
)
934 else if (comp
->attr
.allocatable
&& comp
->ts
.type
!= BT_CLASS
)
936 else if (comp
->ts
.type
== BT_DERIVED
&& !comp
->attr
.pointer
937 && (comp
->ts
.u
.derived
->attr
.alloc_comp
938 || has_finalizer_component (comp
->ts
.u
.derived
)
939 || (comp
->ts
.u
.derived
->f2k_derived
940 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)))
942 else if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
943 && CLASS_DATA (comp
)->attr
.allocatable
)
950 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
951 neither allocatable nor a pointer but has a finalizer, call it. If it
952 is a nonpointer component with allocatable components or has finalizers, walk
953 them. Either of them is required; other nonallocatables and pointers aren't
955 Note: If the component is allocatable, the DEALLOCATE handling takes care
956 of calling the appropriate finalizers, coarray deregistering, and
957 deallocation of allocatable subcomponents. */
960 finalize_component (gfc_expr
*expr
, gfc_symbol
*derived
, gfc_component
*comp
,
961 gfc_symbol
*stat
, gfc_symbol
*fini_coarray
, gfc_code
**code
,
962 gfc_namespace
*sub_ns
)
966 gfc_was_finalized
*f
;
968 if (!comp_is_finalizable (comp
))
971 /* If this expression with this component has been finalized
972 already in this namespace, there is nothing to do. */
973 for (f
= sub_ns
->was_finalized
; f
; f
= f
->next
)
975 if (f
->e
== expr
&& f
->c
== comp
)
979 e
= gfc_copy_expr (expr
);
981 e
->ref
= ref
= gfc_get_ref ();
984 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
986 ref
->next
= gfc_get_ref ();
989 ref
->type
= REF_COMPONENT
;
990 ref
->u
.c
.sym
= derived
;
991 ref
->u
.c
.component
= comp
;
994 if (comp
->attr
.dimension
|| comp
->attr
.codimension
995 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
996 && (CLASS_DATA (comp
)->attr
.dimension
997 || CLASS_DATA (comp
)->attr
.codimension
)))
999 ref
->next
= gfc_get_ref ();
1000 ref
->next
->type
= REF_ARRAY
;
1001 ref
->next
->u
.ar
.dimen
= 0;
1002 ref
->next
->u
.ar
.as
= comp
->ts
.type
== BT_CLASS
? CLASS_DATA (comp
)->as
1004 e
->rank
= ref
->next
->u
.ar
.as
->rank
;
1005 ref
->next
->u
.ar
.type
= e
->rank
? AR_FULL
: AR_ELEMENT
;
1008 /* Call DEALLOCATE (comp, stat=ignore). */
1009 if (comp
->attr
.allocatable
1010 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1011 && CLASS_DATA (comp
)->attr
.allocatable
))
1013 gfc_code
*dealloc
, *block
= NULL
;
1015 /* Add IF (fini_coarray). */
1016 if (comp
->attr
.codimension
1017 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
1018 && CLASS_DATA (comp
)->attr
.codimension
))
1020 block
= gfc_get_code (EXEC_IF
);
1023 (*code
)->next
= block
;
1024 (*code
) = (*code
)->next
;
1029 block
->block
= gfc_get_code (EXEC_IF
);
1030 block
= block
->block
;
1031 block
->expr1
= gfc_lval_expr_from_sym (fini_coarray
);
1034 dealloc
= gfc_get_code (EXEC_DEALLOCATE
);
1036 dealloc
->ext
.alloc
.list
= gfc_get_alloc ();
1037 dealloc
->ext
.alloc
.list
->expr
= e
;
1038 dealloc
->expr1
= gfc_lval_expr_from_sym (stat
);
1040 gfc_code
*cond
= gfc_get_code (EXEC_IF
);
1041 cond
->block
= gfc_get_code (EXEC_IF
);
1042 cond
->block
->expr1
= gfc_get_expr ();
1043 cond
->block
->expr1
->expr_type
= EXPR_FUNCTION
;
1044 cond
->block
->expr1
->where
= gfc_current_locus
;
1045 gfc_get_sym_tree ("associated", sub_ns
, &cond
->block
->expr1
->symtree
, false);
1046 cond
->block
->expr1
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1047 cond
->block
->expr1
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1048 cond
->block
->expr1
->symtree
->n
.sym
->result
= cond
->block
->expr1
->symtree
->n
.sym
;
1049 gfc_commit_symbol (cond
->block
->expr1
->symtree
->n
.sym
);
1050 cond
->block
->expr1
->ts
.type
= BT_LOGICAL
;
1051 cond
->block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1052 cond
->block
->expr1
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED
);
1053 cond
->block
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
1054 cond
->block
->expr1
->value
.function
.actual
->expr
= gfc_copy_expr (expr
);
1055 cond
->block
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1056 cond
->block
->next
= dealloc
;
1062 (*code
)->next
= cond
;
1063 (*code
) = (*code
)->next
;
1069 else if (comp
->ts
.type
== BT_DERIVED
1070 && comp
->ts
.u
.derived
->f2k_derived
1071 && comp
->ts
.u
.derived
->f2k_derived
->finalizers
)
1073 /* Call FINAL_WRAPPER (comp); */
1074 gfc_code
*final_wrap
;
1078 vtab
= gfc_find_derived_vtab (comp
->ts
.u
.derived
);
1079 for (c
= vtab
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1080 if (strcmp (c
->name
, "_final") == 0)
1084 final_wrap
= gfc_get_code (EXEC_CALL
);
1085 final_wrap
->symtree
= c
->initializer
->symtree
;
1086 final_wrap
->resolved_sym
= c
->initializer
->symtree
->n
.sym
;
1087 final_wrap
->ext
.actual
= gfc_get_actual_arglist ();
1088 final_wrap
->ext
.actual
->expr
= e
;
1092 (*code
)->next
= final_wrap
;
1093 (*code
) = (*code
)->next
;
1096 (*code
) = final_wrap
;
1102 for (c
= comp
->ts
.u
.derived
->components
; c
; c
= c
->next
)
1103 finalize_component (e
, comp
->ts
.u
.derived
, c
, stat
, fini_coarray
, code
,
1108 /* Record that this was finalized already in this namespace. */
1109 f
= sub_ns
->was_finalized
;
1110 sub_ns
->was_finalized
= XCNEW (gfc_was_finalized
);
1111 sub_ns
->was_finalized
->e
= expr
;
1112 sub_ns
->was_finalized
->c
= comp
;
1113 sub_ns
->was_finalized
->next
= f
;
1117 /* Generate code equivalent to
1118 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1119 + offset, c_ptr), ptr). */
1122 finalization_scalarizer (gfc_symbol
*array
, gfc_symbol
*ptr
,
1123 gfc_expr
*offset
, gfc_namespace
*sub_ns
)
1126 gfc_expr
*expr
, *expr2
;
1128 /* C_F_POINTER(). */
1129 block
= gfc_get_code (EXEC_CALL
);
1130 gfc_get_sym_tree ("c_f_pointer", sub_ns
, &block
->symtree
, true);
1131 block
->resolved_sym
= block
->symtree
->n
.sym
;
1132 block
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
1133 block
->resolved_sym
->attr
.intrinsic
= 1;
1134 block
->resolved_sym
->attr
.subroutine
= 1;
1135 block
->resolved_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1136 block
->resolved_sym
->intmod_sym_id
= ISOCBINDING_F_POINTER
;
1137 block
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER
);
1138 gfc_commit_symbol (block
->resolved_sym
);
1140 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1141 block
->ext
.actual
= gfc_get_actual_arglist ();
1142 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1143 block
->ext
.actual
->next
->expr
= gfc_get_int_expr (gfc_index_integer_kind
,
1145 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist (); /* SIZE. */
1147 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1149 /* TRANSFER's first argument: C_LOC (array). */
1150 expr
= gfc_get_expr ();
1151 expr
->expr_type
= EXPR_FUNCTION
;
1152 gfc_get_sym_tree ("c_loc", sub_ns
, &expr
->symtree
, false);
1153 expr
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1154 expr
->symtree
->n
.sym
->intmod_sym_id
= ISOCBINDING_LOC
;
1155 expr
->symtree
->n
.sym
->attr
.intrinsic
= 1;
1156 expr
->symtree
->n
.sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
1157 expr
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC
);
1158 expr
->value
.function
.actual
= gfc_get_actual_arglist ();
1159 expr
->value
.function
.actual
->expr
1160 = gfc_lval_expr_from_sym (array
);
1161 expr
->symtree
->n
.sym
->result
= expr
->symtree
->n
.sym
;
1162 gfc_commit_symbol (expr
->symtree
->n
.sym
);
1163 expr
->ts
.type
= BT_INTEGER
;
1164 expr
->ts
.kind
= gfc_index_integer_kind
;
1165 expr
->where
= gfc_current_locus
;
1168 expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_TRANSFER
, "transfer",
1169 gfc_current_locus
, 3, expr
,
1170 gfc_get_int_expr (gfc_index_integer_kind
,
1172 expr2
->ts
.type
= BT_INTEGER
;
1173 expr2
->ts
.kind
= gfc_index_integer_kind
;
1175 /* <array addr> + <offset>. */
1176 block
->ext
.actual
->expr
= gfc_get_expr ();
1177 block
->ext
.actual
->expr
->expr_type
= EXPR_OP
;
1178 block
->ext
.actual
->expr
->value
.op
.op
= INTRINSIC_PLUS
;
1179 block
->ext
.actual
->expr
->value
.op
.op1
= expr2
;
1180 block
->ext
.actual
->expr
->value
.op
.op2
= offset
;
1181 block
->ext
.actual
->expr
->ts
= expr
->ts
;
1182 block
->ext
.actual
->expr
->where
= gfc_current_locus
;
1184 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1185 block
->ext
.actual
->next
= gfc_get_actual_arglist ();
1186 block
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (ptr
);
1187 block
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
1193 /* Calculates the offset to the (idx+1)th element of an array, taking the
1194 stride into account. It generates the code:
1197 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1199 offset = offset * byte_stride. */
1202 finalization_get_offset (gfc_symbol
*idx
, gfc_symbol
*idx2
, gfc_symbol
*offset
,
1203 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1204 gfc_symbol
*byte_stride
, gfc_expr
*rank
,
1205 gfc_code
*block
, gfc_namespace
*sub_ns
)
1208 gfc_expr
*expr
, *expr2
;
1211 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1212 block
= block
->next
;
1213 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1214 block
->expr2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1217 iter
= gfc_get_iterator ();
1218 iter
->var
= gfc_lval_expr_from_sym (idx2
);
1219 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1220 iter
->end
= gfc_copy_expr (rank
);
1221 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1222 block
->next
= gfc_get_code (EXEC_DO
);
1223 block
= block
->next
;
1224 block
->ext
.iterator
= iter
;
1225 block
->block
= gfc_get_code (EXEC_DO
);
1227 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1230 /* mod (idx, sizes(idx2)). */
1231 expr
= gfc_lval_expr_from_sym (sizes
);
1232 expr
->ref
= gfc_get_ref ();
1233 expr
->ref
->type
= REF_ARRAY
;
1234 expr
->ref
->u
.ar
.as
= sizes
->as
;
1235 expr
->ref
->u
.ar
.type
= AR_ELEMENT
;
1236 expr
->ref
->u
.ar
.dimen
= 1;
1237 expr
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1238 expr
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1239 expr
->where
= sizes
->declared_at
;
1241 expr
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_MOD
, "mod",
1242 gfc_current_locus
, 2,
1243 gfc_lval_expr_from_sym (idx
), expr
);
1246 /* (...) / sizes(idx2-1). */
1247 expr2
= gfc_get_expr ();
1248 expr2
->expr_type
= EXPR_OP
;
1249 expr2
->value
.op
.op
= INTRINSIC_DIVIDE
;
1250 expr2
->value
.op
.op1
= expr
;
1251 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1252 expr2
->value
.op
.op2
->ref
= gfc_get_ref ();
1253 expr2
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1254 expr2
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1255 expr2
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1256 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1257 expr2
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1258 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1259 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1260 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1261 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1262 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1263 = gfc_lval_expr_from_sym (idx2
);
1264 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1265 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1266 expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1267 = expr2
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1268 expr2
->ts
= idx
->ts
;
1269 expr2
->where
= gfc_current_locus
;
1271 /* ... * strides(idx2). */
1272 expr
= gfc_get_expr ();
1273 expr
->expr_type
= EXPR_OP
;
1274 expr
->value
.op
.op
= INTRINSIC_TIMES
;
1275 expr
->value
.op
.op1
= expr2
;
1276 expr
->value
.op
.op2
= gfc_lval_expr_from_sym (strides
);
1277 expr
->value
.op
.op2
->ref
= gfc_get_ref ();
1278 expr
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1279 expr
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1280 expr
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1281 expr
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1282 expr
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx2
);
1283 expr
->value
.op
.op2
->ref
->u
.ar
.as
= strides
->as
;
1285 expr
->where
= gfc_current_locus
;
1287 /* offset = offset + ... */
1288 block
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1289 block
->block
->next
->expr1
= gfc_lval_expr_from_sym (offset
);
1290 block
->block
->next
->expr2
= gfc_get_expr ();
1291 block
->block
->next
->expr2
->expr_type
= EXPR_OP
;
1292 block
->block
->next
->expr2
->value
.op
.op
= INTRINSIC_PLUS
;
1293 block
->block
->next
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1294 block
->block
->next
->expr2
->value
.op
.op2
= expr
;
1295 block
->block
->next
->expr2
->ts
= idx
->ts
;
1296 block
->block
->next
->expr2
->where
= gfc_current_locus
;
1298 /* After the loop: offset = offset * byte_stride. */
1299 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1300 block
= block
->next
;
1301 block
->expr1
= gfc_lval_expr_from_sym (offset
);
1302 block
->expr2
= gfc_get_expr ();
1303 block
->expr2
->expr_type
= EXPR_OP
;
1304 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1305 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (offset
);
1306 block
->expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (byte_stride
);
1307 block
->expr2
->ts
= block
->expr2
->value
.op
.op1
->ts
;
1308 block
->expr2
->where
= gfc_current_locus
;
1313 /* Insert code of the following form:
1316 integer(c_intptr_t) :: i
1318 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1319 && (is_contiguous || !final_rank3->attr.contiguous
1320 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1321 || 0 == STORAGE_SIZE (array)) then
1322 call final_rank3 (array)
1325 integer(c_intptr_t) :: offset, j
1326 type(t) :: tmp(shape (array))
1328 do i = 0, size (array)-1
1329 offset = obtain_offset(i, strides, sizes, byte_stride)
1330 addr = transfer (c_loc (array), addr) + offset
1331 call c_f_pointer (transfer (addr, cptr), ptr)
1333 addr = transfer (c_loc (tmp), addr)
1334 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1335 call c_f_pointer (transfer (addr, cptr), ptr2)
1338 call final_rank3 (tmp)
1344 finalizer_insert_packed_call (gfc_code
*block
, gfc_finalizer
*fini
,
1345 gfc_symbol
*array
, gfc_symbol
*byte_stride
,
1346 gfc_symbol
*idx
, gfc_symbol
*ptr
,
1348 gfc_symbol
*strides
, gfc_symbol
*sizes
,
1349 gfc_symbol
*idx2
, gfc_symbol
*offset
,
1350 gfc_symbol
*is_contiguous
, gfc_expr
*rank
,
1351 gfc_namespace
*sub_ns
)
1353 gfc_symbol
*tmp_array
, *ptr2
;
1354 gfc_expr
*size_expr
, *offset2
, *expr
;
1360 block
->next
= gfc_get_code (EXEC_IF
);
1361 block
= block
->next
;
1363 block
->block
= gfc_get_code (EXEC_IF
);
1364 block
= block
->block
;
1366 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1367 size_expr
= gfc_get_expr ();
1368 size_expr
->where
= gfc_current_locus
;
1369 size_expr
->expr_type
= EXPR_OP
;
1370 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
1372 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1373 size_expr
->value
.op
.op1
1374 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STORAGE_SIZE
,
1375 "storage_size", gfc_current_locus
, 2,
1376 gfc_lval_expr_from_sym (array
),
1377 gfc_get_int_expr (gfc_index_integer_kind
,
1380 /* NUMERIC_STORAGE_SIZE. */
1381 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
1382 gfc_character_storage_size
);
1383 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
1384 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
1386 /* IF condition: (stride == size_expr
1387 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1389 || 0 == size_expr. */
1390 block
->expr1
= gfc_get_expr ();
1391 block
->expr1
->ts
.type
= BT_LOGICAL
;
1392 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1393 block
->expr1
->expr_type
= EXPR_OP
;
1394 block
->expr1
->where
= gfc_current_locus
;
1396 block
->expr1
->value
.op
.op
= INTRINSIC_OR
;
1398 /* byte_stride == size_expr */
1399 expr
= gfc_get_expr ();
1400 expr
->ts
.type
= BT_LOGICAL
;
1401 expr
->ts
.kind
= gfc_default_logical_kind
;
1402 expr
->expr_type
= EXPR_OP
;
1403 expr
->where
= gfc_current_locus
;
1404 expr
->value
.op
.op
= INTRINSIC_EQ
;
1406 = gfc_lval_expr_from_sym (byte_stride
);
1407 expr
->value
.op
.op2
= size_expr
;
1409 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1410 add is_contiguous check. */
1412 if (fini
->proc_tree
->n
.sym
->formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
1413 || fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.contiguous
)
1416 expr2
= gfc_get_expr ();
1417 expr2
->ts
.type
= BT_LOGICAL
;
1418 expr2
->ts
.kind
= gfc_default_logical_kind
;
1419 expr2
->expr_type
= EXPR_OP
;
1420 expr2
->where
= gfc_current_locus
;
1421 expr2
->value
.op
.op
= INTRINSIC_AND
;
1422 expr2
->value
.op
.op1
= expr
;
1423 expr2
->value
.op
.op2
= gfc_lval_expr_from_sym (is_contiguous
);
1427 block
->expr1
->value
.op
.op1
= expr
;
1429 /* 0 == size_expr */
1430 block
->expr1
->value
.op
.op2
= gfc_get_expr ();
1431 block
->expr1
->value
.op
.op2
->ts
.type
= BT_LOGICAL
;
1432 block
->expr1
->value
.op
.op2
->ts
.kind
= gfc_default_logical_kind
;
1433 block
->expr1
->value
.op
.op2
->expr_type
= EXPR_OP
;
1434 block
->expr1
->value
.op
.op2
->where
= gfc_current_locus
;
1435 block
->expr1
->value
.op
.op2
->value
.op
.op
= INTRINSIC_EQ
;
1436 block
->expr1
->value
.op
.op2
->value
.op
.op1
=
1437 gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1438 block
->expr1
->value
.op
.op2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1440 /* IF body: call final subroutine. */
1441 block
->next
= gfc_get_code (EXEC_CALL
);
1442 block
->next
->symtree
= fini
->proc_tree
;
1443 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1444 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
1445 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
1446 block
->next
->ext
.actual
->next
= gfc_get_actual_arglist ();
1447 block
->next
->ext
.actual
->next
->expr
= gfc_copy_expr (size_expr
);
1451 block
->block
= gfc_get_code (EXEC_IF
);
1452 block
= block
->block
;
1454 /* BLOCK ... END BLOCK. */
1455 block
->next
= gfc_get_code (EXEC_BLOCK
);
1456 block
= block
->next
;
1458 ns
= gfc_build_block_ns (sub_ns
);
1459 block
->ext
.block
.ns
= ns
;
1460 block
->ext
.block
.assoc
= NULL
;
1462 gfc_get_symbol ("ptr2", ns
, &ptr2
);
1463 ptr2
->ts
.type
= BT_DERIVED
;
1464 ptr2
->ts
.u
.derived
= array
->ts
.u
.derived
;
1465 ptr2
->attr
.flavor
= FL_VARIABLE
;
1466 ptr2
->attr
.pointer
= 1;
1467 ptr2
->attr
.artificial
= 1;
1468 gfc_set_sym_referenced (ptr2
);
1469 gfc_commit_symbol (ptr2
);
1471 gfc_get_symbol ("tmp_array", ns
, &tmp_array
);
1472 tmp_array
->ts
.type
= BT_DERIVED
;
1473 tmp_array
->ts
.u
.derived
= array
->ts
.u
.derived
;
1474 tmp_array
->attr
.flavor
= FL_VARIABLE
;
1475 tmp_array
->attr
.dimension
= 1;
1476 tmp_array
->attr
.artificial
= 1;
1477 tmp_array
->as
= gfc_get_array_spec();
1478 tmp_array
->attr
.intent
= INTENT_INOUT
;
1479 tmp_array
->as
->type
= AS_EXPLICIT
;
1480 tmp_array
->as
->rank
= fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
;
1482 for (i
= 0; i
< tmp_array
->as
->rank
; i
++)
1484 gfc_expr
*shape_expr
;
1485 tmp_array
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1487 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1489 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1490 gfc_current_locus
, 3,
1491 gfc_lval_expr_from_sym (array
),
1492 gfc_get_int_expr (gfc_default_integer_kind
,
1494 gfc_get_int_expr (gfc_default_integer_kind
,
1496 gfc_index_integer_kind
));
1497 shape_expr
->ts
.kind
= gfc_index_integer_kind
;
1498 tmp_array
->as
->upper
[i
] = shape_expr
;
1500 gfc_set_sym_referenced (tmp_array
);
1501 gfc_commit_symbol (tmp_array
);
1504 iter
= gfc_get_iterator ();
1505 iter
->var
= gfc_lval_expr_from_sym (idx
);
1506 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1507 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1508 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1510 block
= gfc_get_code (EXEC_DO
);
1512 block
->ext
.iterator
= iter
;
1513 block
->block
= gfc_get_code (EXEC_DO
);
1515 /* Offset calculation for the new array: idx * size of type (in bytes). */
1516 offset2
= gfc_get_expr ();
1517 offset2
->expr_type
= EXPR_OP
;
1518 offset2
->where
= gfc_current_locus
;
1519 offset2
->value
.op
.op
= INTRINSIC_TIMES
;
1520 offset2
->value
.op
.op1
= gfc_lval_expr_from_sym (idx
);
1521 offset2
->value
.op
.op2
= gfc_copy_expr (size_expr
);
1522 offset2
->ts
= byte_stride
->ts
;
1524 /* Offset calculation of "array". */
1525 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1526 byte_stride
, rank
, block
->block
, sub_ns
);
1529 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1530 + idx * stride, c_ptr), ptr). */
1531 block2
->next
= finalization_scalarizer (array
, ptr
,
1532 gfc_lval_expr_from_sym (offset
),
1534 block2
= block2
->next
;
1535 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
, offset2
, sub_ns
);
1536 block2
= block2
->next
;
1539 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1540 block2
= block2
->next
;
1541 block2
->expr1
= gfc_lval_expr_from_sym (ptr2
);
1542 block2
->expr2
= gfc_lval_expr_from_sym (ptr
);
1544 /* Call now the user's final subroutine. */
1545 block
->next
= gfc_get_code (EXEC_CALL
);
1546 block
= block
->next
;
1547 block
->symtree
= fini
->proc_tree
;
1548 block
->resolved_sym
= fini
->proc_tree
->n
.sym
;
1549 block
->ext
.actual
= gfc_get_actual_arglist ();
1550 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (tmp_array
);
1552 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.intent
== INTENT_IN
)
1558 iter
= gfc_get_iterator ();
1559 iter
->var
= gfc_lval_expr_from_sym (idx
);
1560 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1561 iter
->end
= gfc_lval_expr_from_sym (nelem
);
1562 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1564 block
->next
= gfc_get_code (EXEC_DO
);
1565 block
= block
->next
;
1566 block
->ext
.iterator
= iter
;
1567 block
->block
= gfc_get_code (EXEC_DO
);
1569 /* Offset calculation of "array". */
1570 block2
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
1571 byte_stride
, rank
, block
->block
, sub_ns
);
1574 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1575 + offset, c_ptr), ptr). */
1576 block2
->next
= finalization_scalarizer (array
, ptr
,
1577 gfc_lval_expr_from_sym (offset
),
1579 block2
= block2
->next
;
1580 block2
->next
= finalization_scalarizer (tmp_array
, ptr2
,
1581 gfc_copy_expr (offset2
), sub_ns
);
1582 block2
= block2
->next
;
1585 block2
->next
= gfc_get_code (EXEC_ASSIGN
);
1586 block2
->next
->expr1
= gfc_lval_expr_from_sym (ptr
);
1587 block2
->next
->expr2
= gfc_lval_expr_from_sym (ptr2
);
1591 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1592 derived type "derived". The function first calls the approriate FINAL
1593 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1594 components (but not the inherited ones). Last, it calls the wrapper
1595 subroutine of the parent. The generated wrapper procedure takes as argument
1596 an assumed-rank array.
1597 If neither allocatable components nor FINAL subroutines exists, the vtab
1598 will contain a NULL pointer.
1599 The generated function has the form
1600 _final(assumed-rank array, stride, skip_corarray)
1601 where the array has to be contiguous (except of the lowest dimension). The
1602 stride (in bytes) is used to allow different sizes for ancestor types by
1603 skipping over the additionally added components in the scalarizer. If
1604 "fini_coarray" is false, coarray components are not finalized to allow for
1605 the correct semantic with intrinsic assignment. */
1608 generate_finalization_wrapper (gfc_symbol
*derived
, gfc_namespace
*ns
,
1609 const char *tname
, gfc_component
*vtab_final
)
1611 gfc_symbol
*final
, *array
, *fini_coarray
, *byte_stride
, *sizes
, *strides
;
1612 gfc_symbol
*ptr
= NULL
, *idx
, *idx2
, *is_contiguous
, *offset
, *nelem
;
1613 gfc_component
*comp
;
1614 gfc_namespace
*sub_ns
;
1615 gfc_code
*last_code
, *block
;
1617 bool finalizable_comp
= false;
1618 gfc_expr
*ancestor_wrapper
= NULL
, *rank
;
1621 if (derived
->attr
.unlimited_polymorphic
)
1623 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1627 /* Search for the ancestor's finalizers. */
1628 if (derived
->attr
.extension
&& derived
->components
1629 && (!derived
->components
->ts
.u
.derived
->attr
.abstract
1630 || has_finalizer_component (derived
)))
1633 gfc_component
*comp
;
1635 vtab
= gfc_find_derived_vtab (derived
->components
->ts
.u
.derived
);
1636 for (comp
= vtab
->ts
.u
.derived
->components
; comp
; comp
= comp
->next
)
1637 if (comp
->name
[0] == '_' && comp
->name
[1] == 'f')
1639 ancestor_wrapper
= comp
->initializer
;
1644 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1645 components: Return a NULL() expression; we defer this a bit to have
1646 an interface declaration. */
1647 if ((!ancestor_wrapper
|| ancestor_wrapper
->expr_type
== EXPR_NULL
)
1648 && !derived
->attr
.alloc_comp
1649 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
1650 && !has_finalizer_component (derived
))
1652 vtab_final
->initializer
= gfc_get_null_expr (NULL
);
1653 gcc_assert (vtab_final
->ts
.interface
== NULL
);
1657 /* Check whether there are new allocatable components. */
1658 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
1660 if (comp
== derived
->components
&& derived
->attr
.extension
1661 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
1664 finalizable_comp
|= comp_is_finalizable (comp
);
1667 /* If there is no new finalizer and no new allocatable, return with
1668 an expr to the ancestor's one. */
1669 if (!finalizable_comp
1670 && (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
))
1672 gcc_assert (ancestor_wrapper
&& ancestor_wrapper
->ref
== NULL
1673 && ancestor_wrapper
->expr_type
== EXPR_VARIABLE
);
1674 vtab_final
->initializer
= gfc_copy_expr (ancestor_wrapper
);
1675 vtab_final
->ts
.interface
= vtab_final
->initializer
->symtree
->n
.sym
;
1679 /* We now create a wrapper, which does the following:
1680 1. Call the suitable finalization subroutine for this type
1681 2. Loop over all noninherited allocatable components and noninherited
1682 components with allocatable components and DEALLOCATE those; this will
1683 take care of finalizers, coarray deregistering and allocatable
1685 3. Call the ancestor's finalizer. */
1687 /* Declare the wrapper function; it takes an assumed-rank array
1688 and a VALUE logical as arguments. */
1690 /* Set up the namespace. */
1691 sub_ns
= gfc_get_namespace (ns
, 0);
1692 sub_ns
->sibling
= ns
->contained
;
1693 ns
->contained
= sub_ns
;
1694 sub_ns
->resolved
= 1;
1696 /* Set up the procedure symbol. */
1697 name
= xasprintf ("__final_%s", tname
);
1698 gfc_get_symbol (name
, sub_ns
, &final
);
1699 sub_ns
->proc_name
= final
;
1700 final
->attr
.flavor
= FL_PROCEDURE
;
1701 final
->attr
.function
= 1;
1702 final
->attr
.pure
= 0;
1703 final
->attr
.recursive
= 1;
1704 final
->result
= final
;
1705 final
->ts
.type
= BT_INTEGER
;
1707 final
->attr
.artificial
= 1;
1708 final
->attr
.always_explicit
= 1;
1709 final
->attr
.if_source
= IFSRC_DECL
;
1710 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1711 final
->module
= ns
->proc_name
->name
;
1712 gfc_set_sym_referenced (final
);
1713 gfc_commit_symbol (final
);
1715 /* Set up formal argument. */
1716 gfc_get_symbol ("array", sub_ns
, &array
);
1717 array
->ts
.type
= BT_DERIVED
;
1718 array
->ts
.u
.derived
= derived
;
1719 array
->attr
.flavor
= FL_VARIABLE
;
1720 array
->attr
.dummy
= 1;
1721 array
->attr
.contiguous
= 1;
1722 array
->attr
.dimension
= 1;
1723 array
->attr
.artificial
= 1;
1724 array
->as
= gfc_get_array_spec();
1725 array
->as
->type
= AS_ASSUMED_RANK
;
1726 array
->as
->rank
= -1;
1727 array
->attr
.intent
= INTENT_INOUT
;
1728 gfc_set_sym_referenced (array
);
1729 final
->formal
= gfc_get_formal_arglist ();
1730 final
->formal
->sym
= array
;
1731 gfc_commit_symbol (array
);
1733 /* Set up formal argument. */
1734 gfc_get_symbol ("byte_stride", sub_ns
, &byte_stride
);
1735 byte_stride
->ts
.type
= BT_INTEGER
;
1736 byte_stride
->ts
.kind
= gfc_index_integer_kind
;
1737 byte_stride
->attr
.flavor
= FL_VARIABLE
;
1738 byte_stride
->attr
.dummy
= 1;
1739 byte_stride
->attr
.value
= 1;
1740 byte_stride
->attr
.artificial
= 1;
1741 gfc_set_sym_referenced (byte_stride
);
1742 final
->formal
->next
= gfc_get_formal_arglist ();
1743 final
->formal
->next
->sym
= byte_stride
;
1744 gfc_commit_symbol (byte_stride
);
1746 /* Set up formal argument. */
1747 gfc_get_symbol ("fini_coarray", sub_ns
, &fini_coarray
);
1748 fini_coarray
->ts
.type
= BT_LOGICAL
;
1749 fini_coarray
->ts
.kind
= 1;
1750 fini_coarray
->attr
.flavor
= FL_VARIABLE
;
1751 fini_coarray
->attr
.dummy
= 1;
1752 fini_coarray
->attr
.value
= 1;
1753 fini_coarray
->attr
.artificial
= 1;
1754 gfc_set_sym_referenced (fini_coarray
);
1755 final
->formal
->next
->next
= gfc_get_formal_arglist ();
1756 final
->formal
->next
->next
->sym
= fini_coarray
;
1757 gfc_commit_symbol (fini_coarray
);
1759 /* Local variables. */
1761 gfc_get_symbol ("idx", sub_ns
, &idx
);
1762 idx
->ts
.type
= BT_INTEGER
;
1763 idx
->ts
.kind
= gfc_index_integer_kind
;
1764 idx
->attr
.flavor
= FL_VARIABLE
;
1765 idx
->attr
.artificial
= 1;
1766 gfc_set_sym_referenced (idx
);
1767 gfc_commit_symbol (idx
);
1769 gfc_get_symbol ("idx2", sub_ns
, &idx2
);
1770 idx2
->ts
.type
= BT_INTEGER
;
1771 idx2
->ts
.kind
= gfc_index_integer_kind
;
1772 idx2
->attr
.flavor
= FL_VARIABLE
;
1773 idx2
->attr
.artificial
= 1;
1774 gfc_set_sym_referenced (idx2
);
1775 gfc_commit_symbol (idx2
);
1777 gfc_get_symbol ("offset", sub_ns
, &offset
);
1778 offset
->ts
.type
= BT_INTEGER
;
1779 offset
->ts
.kind
= gfc_index_integer_kind
;
1780 offset
->attr
.flavor
= FL_VARIABLE
;
1781 offset
->attr
.artificial
= 1;
1782 gfc_set_sym_referenced (offset
);
1783 gfc_commit_symbol (offset
);
1785 /* Create RANK expression. */
1786 rank
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_RANK
, "rank",
1787 gfc_current_locus
, 1,
1788 gfc_lval_expr_from_sym (array
));
1789 if (rank
->ts
.kind
!= idx
->ts
.kind
)
1790 gfc_convert_type_warn (rank
, &idx
->ts
, 2, 0);
1792 /* Create is_contiguous variable. */
1793 gfc_get_symbol ("is_contiguous", sub_ns
, &is_contiguous
);
1794 is_contiguous
->ts
.type
= BT_LOGICAL
;
1795 is_contiguous
->ts
.kind
= gfc_default_logical_kind
;
1796 is_contiguous
->attr
.flavor
= FL_VARIABLE
;
1797 is_contiguous
->attr
.artificial
= 1;
1798 gfc_set_sym_referenced (is_contiguous
);
1799 gfc_commit_symbol (is_contiguous
);
1801 /* Create "sizes(0..rank)" variable, which contains the multiplied
1802 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1803 sizes(2) = sizes(1) * extent(dim=2) etc. */
1804 gfc_get_symbol ("sizes", sub_ns
, &sizes
);
1805 sizes
->ts
.type
= BT_INTEGER
;
1806 sizes
->ts
.kind
= gfc_index_integer_kind
;
1807 sizes
->attr
.flavor
= FL_VARIABLE
;
1808 sizes
->attr
.dimension
= 1;
1809 sizes
->attr
.artificial
= 1;
1810 sizes
->as
= gfc_get_array_spec();
1811 sizes
->attr
.intent
= INTENT_INOUT
;
1812 sizes
->as
->type
= AS_EXPLICIT
;
1813 sizes
->as
->rank
= 1;
1814 sizes
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1815 sizes
->as
->upper
[0] = gfc_copy_expr (rank
);
1816 gfc_set_sym_referenced (sizes
);
1817 gfc_commit_symbol (sizes
);
1819 /* Create "strides(1..rank)" variable, which contains the strides per
1821 gfc_get_symbol ("strides", sub_ns
, &strides
);
1822 strides
->ts
.type
= BT_INTEGER
;
1823 strides
->ts
.kind
= gfc_index_integer_kind
;
1824 strides
->attr
.flavor
= FL_VARIABLE
;
1825 strides
->attr
.dimension
= 1;
1826 strides
->attr
.artificial
= 1;
1827 strides
->as
= gfc_get_array_spec();
1828 strides
->attr
.intent
= INTENT_INOUT
;
1829 strides
->as
->type
= AS_EXPLICIT
;
1830 strides
->as
->rank
= 1;
1831 strides
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1832 strides
->as
->upper
[0] = gfc_copy_expr (rank
);
1833 gfc_set_sym_referenced (strides
);
1834 gfc_commit_symbol (strides
);
1837 /* Set return value to 0. */
1838 last_code
= gfc_get_code (EXEC_ASSIGN
);
1839 last_code
->expr1
= gfc_lval_expr_from_sym (final
);
1840 last_code
->expr2
= gfc_get_int_expr (4, NULL
, 0);
1841 sub_ns
->code
= last_code
;
1843 /* Set: is_contiguous = .true. */
1844 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1845 last_code
= last_code
->next
;
1846 last_code
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1847 last_code
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1848 &gfc_current_locus
, true);
1850 /* Set: sizes(0) = 1. */
1851 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
1852 last_code
= last_code
->next
;
1853 last_code
->expr1
= gfc_lval_expr_from_sym (sizes
);
1854 last_code
->expr1
->ref
= gfc_get_ref ();
1855 last_code
->expr1
->ref
->type
= REF_ARRAY
;
1856 last_code
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1857 last_code
->expr1
->ref
->u
.ar
.dimen
= 1;
1858 last_code
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1859 last_code
->expr1
->ref
->u
.ar
.start
[0]
1860 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
1861 last_code
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1862 last_code
->expr2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1866 strides(idx) = _F._stride (array, dim=idx)
1867 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1868 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1872 iter
= gfc_get_iterator ();
1873 iter
->var
= gfc_lval_expr_from_sym (idx
);
1874 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1875 iter
->end
= gfc_copy_expr (rank
);
1876 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1877 last_code
->next
= gfc_get_code (EXEC_DO
);
1878 last_code
= last_code
->next
;
1879 last_code
->ext
.iterator
= iter
;
1880 last_code
->block
= gfc_get_code (EXEC_DO
);
1882 /* strides(idx) = _F._stride(array,dim=idx). */
1883 last_code
->block
->next
= gfc_get_code (EXEC_ASSIGN
);
1884 block
= last_code
->block
->next
;
1886 block
->expr1
= gfc_lval_expr_from_sym (strides
);
1887 block
->expr1
->ref
= gfc_get_ref ();
1888 block
->expr1
->ref
->type
= REF_ARRAY
;
1889 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1890 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1891 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1892 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1893 block
->expr1
->ref
->u
.ar
.as
= strides
->as
;
1895 block
->expr2
= gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_STRIDE
, "stride",
1896 gfc_current_locus
, 2,
1897 gfc_lval_expr_from_sym (array
),
1898 gfc_lval_expr_from_sym (idx
));
1900 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1901 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1902 block
= block
->next
;
1904 /* sizes(idx) = ... */
1905 block
->expr1
= gfc_lval_expr_from_sym (sizes
);
1906 block
->expr1
->ref
= gfc_get_ref ();
1907 block
->expr1
->ref
->type
= REF_ARRAY
;
1908 block
->expr1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1909 block
->expr1
->ref
->u
.ar
.dimen
= 1;
1910 block
->expr1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1911 block
->expr1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1912 block
->expr1
->ref
->u
.ar
.as
= sizes
->as
;
1914 block
->expr2
= gfc_get_expr ();
1915 block
->expr2
->expr_type
= EXPR_OP
;
1916 block
->expr2
->value
.op
.op
= INTRINSIC_TIMES
;
1917 block
->expr2
->where
= gfc_current_locus
;
1920 block
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
1921 block
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
1922 block
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1923 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
1924 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1925 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1926 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1927 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1928 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1929 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1930 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1931 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
1932 = gfc_lval_expr_from_sym (idx
);
1933 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op2
1934 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1935 block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->ts
1936 = block
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1938 /* size(array, dim=idx, kind=index_kind). */
1939 block
->expr2
->value
.op
.op2
1940 = gfc_build_intrinsic_call (sub_ns
, GFC_ISYM_SIZE
, "size",
1941 gfc_current_locus
, 3,
1942 gfc_lval_expr_from_sym (array
),
1943 gfc_lval_expr_from_sym (idx
),
1944 gfc_get_int_expr (gfc_index_integer_kind
,
1946 gfc_index_integer_kind
));
1947 block
->expr2
->value
.op
.op2
->ts
.kind
= gfc_index_integer_kind
;
1948 block
->expr2
->ts
= idx
->ts
;
1950 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1951 block
->next
= gfc_get_code (EXEC_IF
);
1952 block
= block
->next
;
1954 block
->block
= gfc_get_code (EXEC_IF
);
1955 block
= block
->block
;
1957 /* if condition: strides(idx) /= sizes(idx-1). */
1958 block
->expr1
= gfc_get_expr ();
1959 block
->expr1
->ts
.type
= BT_LOGICAL
;
1960 block
->expr1
->ts
.kind
= gfc_default_logical_kind
;
1961 block
->expr1
->expr_type
= EXPR_OP
;
1962 block
->expr1
->where
= gfc_current_locus
;
1963 block
->expr1
->value
.op
.op
= INTRINSIC_NE
;
1965 block
->expr1
->value
.op
.op1
= gfc_lval_expr_from_sym (strides
);
1966 block
->expr1
->value
.op
.op1
->ref
= gfc_get_ref ();
1967 block
->expr1
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
1968 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
1969 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
1970 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1971 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_lval_expr_from_sym (idx
);
1972 block
->expr1
->value
.op
.op1
->ref
->u
.ar
.as
= strides
->as
;
1974 block
->expr1
->value
.op
.op2
= gfc_lval_expr_from_sym (sizes
);
1975 block
->expr1
->value
.op
.op2
->ref
= gfc_get_ref ();
1976 block
->expr1
->value
.op
.op2
->ref
->type
= REF_ARRAY
;
1977 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.as
= sizes
->as
;
1978 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.type
= AR_ELEMENT
;
1979 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen
= 1;
1980 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
1981 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0] = gfc_get_expr ();
1982 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->expr_type
= EXPR_OP
;
1983 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->where
= gfc_current_locus
;
1984 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op
= INTRINSIC_MINUS
;
1985 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
1986 = gfc_lval_expr_from_sym (idx
);
1987 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op2
1988 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1989 block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->ts
1990 = block
->expr1
->value
.op
.op2
->ref
->u
.ar
.start
[0]->value
.op
.op1
->ts
;
1992 /* if body: is_contiguous = .false. */
1993 block
->next
= gfc_get_code (EXEC_ASSIGN
);
1994 block
= block
->next
;
1995 block
->expr1
= gfc_lval_expr_from_sym (is_contiguous
);
1996 block
->expr2
= gfc_get_logical_expr (gfc_default_logical_kind
,
1997 &gfc_current_locus
, false);
1999 /* Obtain the size (number of elements) of "array" MINUS ONE,
2000 which is used in the scalarization. */
2001 gfc_get_symbol ("nelem", sub_ns
, &nelem
);
2002 nelem
->ts
.type
= BT_INTEGER
;
2003 nelem
->ts
.kind
= gfc_index_integer_kind
;
2004 nelem
->attr
.flavor
= FL_VARIABLE
;
2005 nelem
->attr
.artificial
= 1;
2006 gfc_set_sym_referenced (nelem
);
2007 gfc_commit_symbol (nelem
);
2009 /* nelem = sizes (rank) - 1. */
2010 last_code
->next
= gfc_get_code (EXEC_ASSIGN
);
2011 last_code
= last_code
->next
;
2013 last_code
->expr1
= gfc_lval_expr_from_sym (nelem
);
2015 last_code
->expr2
= gfc_get_expr ();
2016 last_code
->expr2
->expr_type
= EXPR_OP
;
2017 last_code
->expr2
->value
.op
.op
= INTRINSIC_MINUS
;
2018 last_code
->expr2
->value
.op
.op2
2019 = gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2020 last_code
->expr2
->ts
= last_code
->expr2
->value
.op
.op2
->ts
;
2021 last_code
->expr2
->where
= gfc_current_locus
;
2023 last_code
->expr2
->value
.op
.op1
= gfc_lval_expr_from_sym (sizes
);
2024 last_code
->expr2
->value
.op
.op1
->ref
= gfc_get_ref ();
2025 last_code
->expr2
->value
.op
.op1
->ref
->type
= REF_ARRAY
;
2026 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.type
= AR_ELEMENT
;
2027 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen
= 1;
2028 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.dimen_type
[0] = DIMEN_ELEMENT
;
2029 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.start
[0] = gfc_copy_expr (rank
);
2030 last_code
->expr2
->value
.op
.op1
->ref
->u
.ar
.as
= sizes
->as
;
2032 /* Call final subroutines. We now generate code like:
2034 integer, pointer :: ptr
2036 integer(c_intptr_t) :: i, addr
2038 select case (rank (array))
2040 ! If needed, the array is packed
2041 call final_rank3 (array)
2043 do i = 0, size (array)-1
2044 addr = transfer (c_loc (array), addr) + i * stride
2045 call c_f_pointer (transfer (addr, cptr), ptr)
2046 call elemental_final (ptr)
2050 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2052 gfc_finalizer
*fini
, *fini_elem
= NULL
;
2054 gfc_get_symbol ("ptr1", sub_ns
, &ptr
);
2055 ptr
->ts
.type
= BT_DERIVED
;
2056 ptr
->ts
.u
.derived
= derived
;
2057 ptr
->attr
.flavor
= FL_VARIABLE
;
2058 ptr
->attr
.pointer
= 1;
2059 ptr
->attr
.artificial
= 1;
2060 gfc_set_sym_referenced (ptr
);
2061 gfc_commit_symbol (ptr
);
2063 /* SELECT CASE (RANK (array)). */
2064 last_code
->next
= gfc_get_code (EXEC_SELECT
);
2065 last_code
= last_code
->next
;
2066 last_code
->expr1
= gfc_copy_expr (rank
);
2069 for (fini
= derived
->f2k_derived
->finalizers
; fini
; fini
= fini
->next
)
2071 gcc_assert (fini
->proc_tree
); /* Should have been set in gfc_resolve_finalizers. */
2072 if (fini
->proc_tree
->n
.sym
->attr
.elemental
)
2078 /* CASE (fini_rank). */
2081 block
->block
= gfc_get_code (EXEC_SELECT
);
2082 block
= block
->block
;
2086 block
= gfc_get_code (EXEC_SELECT
);
2087 last_code
->block
= block
;
2089 block
->ext
.block
.case_list
= gfc_get_case ();
2090 block
->ext
.block
.case_list
->where
= gfc_current_locus
;
2091 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2092 block
->ext
.block
.case_list
->low
2093 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2094 fini
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
);
2096 block
->ext
.block
.case_list
->low
2097 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2098 block
->ext
.block
.case_list
->high
2099 = gfc_copy_expr (block
->ext
.block
.case_list
->low
);
2101 /* CALL fini_rank (array) - possibly with packing. */
2102 if (fini
->proc_tree
->n
.sym
->formal
->sym
->attr
.dimension
)
2103 finalizer_insert_packed_call (block
, fini
, array
, byte_stride
,
2104 idx
, ptr
, nelem
, strides
,
2105 sizes
, idx2
, offset
, is_contiguous
,
2109 block
->next
= gfc_get_code (EXEC_CALL
);
2110 block
->next
->symtree
= fini
->proc_tree
;
2111 block
->next
->resolved_sym
= fini
->proc_tree
->n
.sym
;
2112 block
->next
->ext
.actual
= gfc_get_actual_arglist ();
2113 block
->next
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2117 /* Elemental call - scalarized. */
2123 block
->block
= gfc_get_code (EXEC_SELECT
);
2124 block
= block
->block
;
2128 block
= gfc_get_code (EXEC_SELECT
);
2129 last_code
->block
= block
;
2131 block
->ext
.block
.case_list
= gfc_get_case ();
2134 iter
= gfc_get_iterator ();
2135 iter
->var
= gfc_lval_expr_from_sym (idx
);
2136 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2137 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2138 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2139 block
->next
= gfc_get_code (EXEC_DO
);
2140 block
= block
->next
;
2141 block
->ext
.iterator
= iter
;
2142 block
->block
= gfc_get_code (EXEC_DO
);
2144 /* Offset calculation. */
2145 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2146 byte_stride
, rank
, block
->block
,
2150 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2151 + offset, c_ptr), ptr). */
2153 = finalization_scalarizer (array
, ptr
,
2154 gfc_lval_expr_from_sym (offset
),
2156 block
= block
->next
;
2158 /* CALL final_elemental (array). */
2159 block
->next
= gfc_get_code (EXEC_CALL
);
2160 block
= block
->next
;
2161 block
->symtree
= fini_elem
->proc_tree
;
2162 block
->resolved_sym
= fini_elem
->proc_sym
;
2163 block
->ext
.actual
= gfc_get_actual_arglist ();
2164 block
->ext
.actual
->expr
= gfc_lval_expr_from_sym (ptr
);
2168 /* Finalize and deallocate allocatable components. The same manual
2169 scalarization is used as above. */
2171 if (finalizable_comp
)
2174 gfc_code
*block
= NULL
;
2178 gfc_get_symbol ("ptr2", sub_ns
, &ptr
);
2179 ptr
->ts
.type
= BT_DERIVED
;
2180 ptr
->ts
.u
.derived
= derived
;
2181 ptr
->attr
.flavor
= FL_VARIABLE
;
2182 ptr
->attr
.pointer
= 1;
2183 ptr
->attr
.artificial
= 1;
2184 gfc_set_sym_referenced (ptr
);
2185 gfc_commit_symbol (ptr
);
2188 gfc_get_symbol ("ignore", sub_ns
, &stat
);
2189 stat
->attr
.flavor
= FL_VARIABLE
;
2190 stat
->attr
.artificial
= 1;
2191 stat
->ts
.type
= BT_INTEGER
;
2192 stat
->ts
.kind
= gfc_default_integer_kind
;
2193 gfc_set_sym_referenced (stat
);
2194 gfc_commit_symbol (stat
);
2197 iter
= gfc_get_iterator ();
2198 iter
->var
= gfc_lval_expr_from_sym (idx
);
2199 iter
->start
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 0);
2200 iter
->end
= gfc_lval_expr_from_sym (nelem
);
2201 iter
->step
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
2202 last_code
->next
= gfc_get_code (EXEC_DO
);
2203 last_code
= last_code
->next
;
2204 last_code
->ext
.iterator
= iter
;
2205 last_code
->block
= gfc_get_code (EXEC_DO
);
2207 /* Offset calculation. */
2208 block
= finalization_get_offset (idx
, idx2
, offset
, strides
, sizes
,
2209 byte_stride
, rank
, last_code
->block
,
2213 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2214 + idx * stride, c_ptr), ptr). */
2215 block
->next
= finalization_scalarizer (array
, ptr
,
2216 gfc_lval_expr_from_sym(offset
),
2218 block
= block
->next
;
2220 for (comp
= derived
->components
; comp
; comp
= comp
->next
)
2222 if (comp
== derived
->components
&& derived
->attr
.extension
2223 && ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2226 finalize_component (gfc_lval_expr_from_sym (ptr
), derived
, comp
,
2227 stat
, fini_coarray
, &block
, sub_ns
);
2228 if (!last_code
->block
->next
)
2229 last_code
->block
->next
= block
;
2234 /* Call the finalizer of the ancestor. */
2235 if (ancestor_wrapper
&& ancestor_wrapper
->expr_type
!= EXPR_NULL
)
2237 last_code
->next
= gfc_get_code (EXEC_CALL
);
2238 last_code
= last_code
->next
;
2239 last_code
->symtree
= ancestor_wrapper
->symtree
;
2240 last_code
->resolved_sym
= ancestor_wrapper
->symtree
->n
.sym
;
2242 last_code
->ext
.actual
= gfc_get_actual_arglist ();
2243 last_code
->ext
.actual
->expr
= gfc_lval_expr_from_sym (array
);
2244 last_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
2245 last_code
->ext
.actual
->next
->expr
= gfc_lval_expr_from_sym (byte_stride
);
2246 last_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
2247 last_code
->ext
.actual
->next
->next
->expr
2248 = gfc_lval_expr_from_sym (fini_coarray
);
2251 gfc_free_expr (rank
);
2252 vtab_final
->initializer
= gfc_lval_expr_from_sym (final
);
2253 vtab_final
->ts
.interface
= final
;
2258 /* Add procedure pointers for all type-bound procedures to a vtab. */
2261 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
2263 gfc_symbol
* super_type
;
2265 super_type
= gfc_get_derived_super_type (derived
);
2267 if (super_type
&& (super_type
!= derived
))
2269 /* Make sure that the PPCs appear in the same order as in the parent. */
2270 copy_vtab_proc_comps (super_type
, vtype
);
2271 /* Only needed to get the PPC initializers right. */
2272 add_procs_to_declared_vtab (super_type
, vtype
);
2275 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
2276 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
2278 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
2279 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
2283 /* Find or generate the symbol for a derived type's vtab. */
2286 gfc_find_derived_vtab (gfc_symbol
*derived
)
2289 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
2290 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2291 gfc_gsymbol
*gsym
= NULL
;
2292 gfc_symbol
*dealloc
= NULL
, *arg
= NULL
;
2294 if (derived
->attr
.pdt_template
)
2297 /* Find the top-level namespace. */
2298 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2302 /* If the type is a class container, use the underlying derived type. */
2303 if (!derived
->attr
.unlimited_polymorphic
&& derived
->attr
.is_class
)
2304 derived
= gfc_get_derived_super_type (derived
);
2312 /* Find the gsymbol for the module of use associated derived types. */
2313 if ((derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2314 && !derived
->attr
.vtype
&& !derived
->attr
.is_class
)
2315 gsym
= gfc_find_gsymbol (gfc_gsym_root
, derived
->module
);
2319 /* Work in the gsymbol namespace if the top-level namespace is a module.
2320 This ensures that the vtable is unique, which is required since we use
2321 its address in SELECT TYPE. */
2322 if (gsym
&& gsym
->ns
&& ns
&& ns
->proc_name
2323 && ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2328 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2331 get_unique_hashed_string (tname
, derived
);
2332 name
= xasprintf ("__vtab_%s", tname
);
2334 /* Look for the vtab symbol in various namespaces. */
2335 if (gsym
&& gsym
->ns
)
2337 gfc_find_symbol (name
, gsym
->ns
, 0, &vtab
);
2342 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
2344 gfc_find_symbol (name
, ns
, 0, &vtab
);
2346 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
2350 gfc_get_symbol (name
, ns
, &vtab
);
2351 vtab
->ts
.type
= BT_DERIVED
;
2352 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2353 &gfc_current_locus
))
2355 vtab
->attr
.target
= 1;
2356 vtab
->attr
.save
= SAVE_IMPLICIT
;
2357 vtab
->attr
.vtab
= 1;
2358 vtab
->attr
.access
= ACCESS_PUBLIC
;
2359 gfc_set_sym_referenced (vtab
);
2361 name
= xasprintf ("__vtype_%s", tname
);
2363 gfc_find_symbol (name
, ns
, 0, &vtype
);
2367 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
2370 /* Is this a derived type with recursive allocatable
2372 c
= (derived
->attr
.unlimited_polymorphic
2373 || derived
->attr
.abstract
) ?
2374 NULL
: derived
->components
;
2375 for (; c
; c
= c
->next
)
2376 if (c
->ts
.type
== BT_DERIVED
2377 && c
->ts
.u
.derived
== derived
)
2383 gfc_get_symbol (name
, ns
, &vtype
);
2384 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2385 &gfc_current_locus
))
2387 vtype
->attr
.access
= ACCESS_PUBLIC
;
2388 vtype
->attr
.vtype
= 1;
2389 gfc_set_sym_referenced (vtype
);
2391 /* Add component '_hash'. */
2392 if (!gfc_add_component (vtype
, "_hash", &c
))
2394 c
->ts
.type
= BT_INTEGER
;
2396 c
->attr
.access
= ACCESS_PRIVATE
;
2397 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2398 NULL
, derived
->hash_value
);
2400 /* Add component '_size'. */
2401 if (!gfc_add_component (vtype
, "_size", &c
))
2403 c
->ts
.type
= BT_INTEGER
;
2404 c
->ts
.kind
= gfc_size_kind
;
2405 c
->attr
.access
= ACCESS_PRIVATE
;
2406 /* Remember the derived type in ts.u.derived,
2407 so that the correct initializer can be set later on
2408 (in gfc_conv_structure). */
2409 c
->ts
.u
.derived
= derived
;
2410 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2413 /* Add component _extends. */
2414 if (!gfc_add_component (vtype
, "_extends", &c
))
2416 c
->attr
.pointer
= 1;
2417 c
->attr
.access
= ACCESS_PRIVATE
;
2418 if (!derived
->attr
.unlimited_polymorphic
)
2419 parent
= gfc_get_derived_super_type (derived
);
2425 parent_vtab
= gfc_find_derived_vtab (parent
);
2426 c
->ts
.type
= BT_DERIVED
;
2427 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
2428 c
->initializer
= gfc_get_expr ();
2429 c
->initializer
->expr_type
= EXPR_VARIABLE
;
2430 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
2431 0, &c
->initializer
->symtree
);
2435 c
->ts
.type
= BT_DERIVED
;
2436 c
->ts
.u
.derived
= vtype
;
2437 c
->initializer
= gfc_get_null_expr (NULL
);
2440 if (!derived
->attr
.unlimited_polymorphic
2441 && derived
->components
== NULL
2442 && !derived
->attr
.zero_comp
)
2444 /* At this point an error must have occurred.
2445 Prevent further errors on the vtype components. */
2450 /* Add component _def_init. */
2451 if (!gfc_add_component (vtype
, "_def_init", &c
))
2453 c
->attr
.pointer
= 1;
2454 c
->attr
.artificial
= 1;
2455 c
->attr
.access
= ACCESS_PRIVATE
;
2456 c
->ts
.type
= BT_DERIVED
;
2457 c
->ts
.u
.derived
= derived
;
2458 if (derived
->attr
.unlimited_polymorphic
2459 || derived
->attr
.abstract
)
2460 c
->initializer
= gfc_get_null_expr (NULL
);
2463 /* Construct default initialization variable. */
2465 name
= xasprintf ("__def_init_%s", tname
);
2466 gfc_get_symbol (name
, ns
, &def_init
);
2467 def_init
->attr
.target
= 1;
2468 def_init
->attr
.artificial
= 1;
2469 def_init
->attr
.save
= SAVE_IMPLICIT
;
2470 def_init
->attr
.access
= ACCESS_PUBLIC
;
2471 def_init
->attr
.flavor
= FL_VARIABLE
;
2472 gfc_set_sym_referenced (def_init
);
2473 def_init
->ts
.type
= BT_DERIVED
;
2474 def_init
->ts
.u
.derived
= derived
;
2475 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
2477 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
2480 /* Add component _copy. */
2481 if (!gfc_add_component (vtype
, "_copy", &c
))
2483 c
->attr
.proc_pointer
= 1;
2484 c
->attr
.access
= ACCESS_PRIVATE
;
2485 c
->tb
= XCNEW (gfc_typebound_proc
);
2487 if (derived
->attr
.unlimited_polymorphic
2488 || derived
->attr
.abstract
)
2489 c
->initializer
= gfc_get_null_expr (NULL
);
2492 /* Set up namespace. */
2493 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2494 sub_ns
->sibling
= ns
->contained
;
2495 ns
->contained
= sub_ns
;
2496 sub_ns
->resolved
= 1;
2497 /* Set up procedure symbol. */
2499 name
= xasprintf ("__copy_%s", tname
);
2500 gfc_get_symbol (name
, sub_ns
, ©
);
2501 sub_ns
->proc_name
= copy
;
2502 copy
->attr
.flavor
= FL_PROCEDURE
;
2503 copy
->attr
.subroutine
= 1;
2504 copy
->attr
.pure
= 1;
2505 copy
->attr
.artificial
= 1;
2506 copy
->attr
.if_source
= IFSRC_DECL
;
2507 /* This is elemental so that arrays are automatically
2508 treated correctly by the scalarizer. */
2509 copy
->attr
.elemental
= 1;
2510 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2511 copy
->module
= ns
->proc_name
->name
;
2512 gfc_set_sym_referenced (copy
);
2513 /* Set up formal arguments. */
2514 gfc_get_symbol ("src", sub_ns
, &src
);
2515 src
->ts
.type
= BT_DERIVED
;
2516 src
->ts
.u
.derived
= derived
;
2517 src
->attr
.flavor
= FL_VARIABLE
;
2518 src
->attr
.dummy
= 1;
2519 src
->attr
.artificial
= 1;
2520 src
->attr
.intent
= INTENT_IN
;
2521 gfc_set_sym_referenced (src
);
2522 copy
->formal
= gfc_get_formal_arglist ();
2523 copy
->formal
->sym
= src
;
2524 gfc_get_symbol ("dst", sub_ns
, &dst
);
2525 dst
->ts
.type
= BT_DERIVED
;
2526 dst
->ts
.u
.derived
= derived
;
2527 dst
->attr
.flavor
= FL_VARIABLE
;
2528 dst
->attr
.dummy
= 1;
2529 dst
->attr
.artificial
= 1;
2530 dst
->attr
.intent
= INTENT_INOUT
;
2531 gfc_set_sym_referenced (dst
);
2532 copy
->formal
->next
= gfc_get_formal_arglist ();
2533 copy
->formal
->next
->sym
= dst
;
2535 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2536 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2537 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2538 /* Set initializer. */
2539 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2540 c
->ts
.interface
= copy
;
2543 /* Add component _final, which contains a procedure pointer to
2544 a wrapper which handles both the freeing of allocatable
2545 components and the calls to finalization subroutines.
2546 Note: The actual wrapper function can only be generated
2547 at resolution time. */
2548 if (!gfc_add_component (vtype
, "_final", &c
))
2550 c
->attr
.proc_pointer
= 1;
2551 c
->attr
.access
= ACCESS_PRIVATE
;
2552 c
->attr
.artificial
= 1;
2553 c
->tb
= XCNEW (gfc_typebound_proc
);
2555 generate_finalization_wrapper (derived
, ns
, tname
, c
);
2557 /* Add component _deallocate. */
2558 if (!gfc_add_component (vtype
, "_deallocate", &c
))
2560 c
->attr
.proc_pointer
= 1;
2561 c
->attr
.access
= ACCESS_PRIVATE
;
2562 c
->tb
= XCNEW (gfc_typebound_proc
);
2564 if (derived
->attr
.unlimited_polymorphic
2565 || derived
->attr
.abstract
2567 c
->initializer
= gfc_get_null_expr (NULL
);
2570 /* Set up namespace. */
2571 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
2573 sub_ns
->sibling
= ns
->contained
;
2574 ns
->contained
= sub_ns
;
2575 sub_ns
->resolved
= 1;
2576 /* Set up procedure symbol. */
2578 name
= xasprintf ("__deallocate_%s", tname
);
2579 gfc_get_symbol (name
, sub_ns
, &dealloc
);
2580 sub_ns
->proc_name
= dealloc
;
2581 dealloc
->attr
.flavor
= FL_PROCEDURE
;
2582 dealloc
->attr
.subroutine
= 1;
2583 dealloc
->attr
.pure
= 1;
2584 dealloc
->attr
.artificial
= 1;
2585 dealloc
->attr
.if_source
= IFSRC_DECL
;
2587 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2588 dealloc
->module
= ns
->proc_name
->name
;
2589 gfc_set_sym_referenced (dealloc
);
2590 /* Set up formal argument. */
2591 gfc_get_symbol ("arg", sub_ns
, &arg
);
2592 arg
->ts
.type
= BT_DERIVED
;
2593 arg
->ts
.u
.derived
= derived
;
2594 arg
->attr
.flavor
= FL_VARIABLE
;
2595 arg
->attr
.dummy
= 1;
2596 arg
->attr
.artificial
= 1;
2597 arg
->attr
.intent
= INTENT_INOUT
;
2598 arg
->attr
.dimension
= 1;
2599 arg
->attr
.allocatable
= 1;
2600 arg
->as
= gfc_get_array_spec();
2601 arg
->as
->type
= AS_ASSUMED_SHAPE
;
2603 arg
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2605 gfc_set_sym_referenced (arg
);
2606 dealloc
->formal
= gfc_get_formal_arglist ();
2607 dealloc
->formal
->sym
= arg
;
2609 sub_ns
->code
= gfc_get_code (EXEC_DEALLOCATE
);
2610 sub_ns
->code
->ext
.alloc
.list
= gfc_get_alloc ();
2611 sub_ns
->code
->ext
.alloc
.list
->expr
2612 = gfc_lval_expr_from_sym (arg
);
2613 /* Set initializer. */
2614 c
->initializer
= gfc_lval_expr_from_sym (dealloc
);
2615 c
->ts
.interface
= dealloc
;
2618 /* Add procedure pointers for type-bound procedures. */
2619 if (!derived
->attr
.unlimited_polymorphic
)
2620 add_procs_to_declared_vtab (derived
, vtype
);
2624 vtab
->ts
.u
.derived
= vtype
;
2625 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2633 /* It is unexpected to have some symbols added at resolution or code
2634 generation time. We commit the changes in order to keep a clean state. */
2637 gfc_commit_symbol (vtab
);
2639 gfc_commit_symbol (vtype
);
2641 gfc_commit_symbol (def_init
);
2643 gfc_commit_symbol (copy
);
2645 gfc_commit_symbol (src
);
2647 gfc_commit_symbol (dst
);
2649 gfc_commit_symbol (dealloc
);
2651 gfc_commit_symbol (arg
);
2654 gfc_undo_symbols ();
2660 /* Check if a derived type is finalizable. That is the case if it
2661 (1) has a FINAL subroutine or
2662 (2) has a nonpointer nonallocatable component of finalizable type.
2663 If it is finalizable, return an expression containing the
2664 finalization wrapper. */
2667 gfc_is_finalizable (gfc_symbol
*derived
, gfc_expr
**final_expr
)
2672 /* (1) Check for FINAL subroutines. */
2673 if (derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
)
2676 /* (2) Check for components of finalizable type. */
2677 for (c
= derived
->components
; c
; c
= c
->next
)
2678 if (c
->ts
.type
== BT_DERIVED
2679 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
2680 && gfc_is_finalizable (c
->ts
.u
.derived
, NULL
))
2686 /* Make sure vtab is generated. */
2687 vtab
= gfc_find_derived_vtab (derived
);
2690 /* Return finalizer expression. */
2691 gfc_component
*final
;
2692 final
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
2693 gcc_assert (strcmp (final
->name
, "_final") == 0);
2694 gcc_assert (final
->initializer
2695 && final
->initializer
->expr_type
!= EXPR_NULL
);
2696 *final_expr
= final
->initializer
;
2702 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2703 needed to support unlimited polymorphism. */
2706 find_intrinsic_vtab (gfc_typespec
*ts
)
2709 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
;
2710 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
2712 /* Find the top-level namespace. */
2713 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2719 char tname
[GFC_MAX_SYMBOL_LEN
+1];
2722 /* Encode all types as TYPENAME_KIND_ including especially character
2723 arrays, whose length is now consistently stored in the _len component
2724 of the class-variable. */
2725 sprintf (tname
, "%s_%d_", gfc_basic_typename (ts
->type
), ts
->kind
);
2726 name
= xasprintf ("__vtab_%s", tname
);
2728 /* Look for the vtab symbol in the top-level namespace only. */
2729 gfc_find_symbol (name
, ns
, 0, &vtab
);
2733 gfc_get_symbol (name
, ns
, &vtab
);
2734 vtab
->ts
.type
= BT_DERIVED
;
2735 if (!gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
2736 &gfc_current_locus
))
2738 vtab
->attr
.target
= 1;
2739 vtab
->attr
.save
= SAVE_IMPLICIT
;
2740 vtab
->attr
.vtab
= 1;
2741 vtab
->attr
.access
= ACCESS_PUBLIC
;
2742 gfc_set_sym_referenced (vtab
);
2744 name
= xasprintf ("__vtype_%s", tname
);
2746 gfc_find_symbol (name
, ns
, 0, &vtype
);
2751 gfc_namespace
*sub_ns
;
2752 gfc_namespace
*contained
;
2756 gfc_get_symbol (name
, ns
, &vtype
);
2757 if (!gfc_add_flavor (&vtype
->attr
, FL_DERIVED
, NULL
,
2758 &gfc_current_locus
))
2760 vtype
->attr
.access
= ACCESS_PUBLIC
;
2761 vtype
->attr
.vtype
= 1;
2762 gfc_set_sym_referenced (vtype
);
2764 /* Add component '_hash'. */
2765 if (!gfc_add_component (vtype
, "_hash", &c
))
2767 c
->ts
.type
= BT_INTEGER
;
2769 c
->attr
.access
= ACCESS_PRIVATE
;
2770 hash
= gfc_intrinsic_hash_value (ts
);
2771 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
2774 /* Add component '_size'. */
2775 if (!gfc_add_component (vtype
, "_size", &c
))
2777 c
->ts
.type
= BT_INTEGER
;
2778 c
->ts
.kind
= gfc_size_kind
;
2779 c
->attr
.access
= ACCESS_PRIVATE
;
2781 /* Build a minimal expression to make use of
2782 target-memory.cc/gfc_element_size for 'size'. Special handling
2783 for character arrays, that are not constant sized: to support
2784 len (str) * kind, only the kind information is stored in the
2786 e
= gfc_get_expr ();
2788 e
->expr_type
= EXPR_VARIABLE
;
2789 if (ts
->type
== BT_CHARACTER
)
2792 gfc_element_size (e
, &e_size
);
2793 c
->initializer
= gfc_get_int_expr (gfc_size_kind
,
2798 /* Add component _extends. */
2799 if (!gfc_add_component (vtype
, "_extends", &c
))
2801 c
->attr
.pointer
= 1;
2802 c
->attr
.access
= ACCESS_PRIVATE
;
2803 c
->ts
.type
= BT_VOID
;
2804 c
->initializer
= gfc_get_null_expr (NULL
);
2806 /* Add component _def_init. */
2807 if (!gfc_add_component (vtype
, "_def_init", &c
))
2809 c
->attr
.pointer
= 1;
2810 c
->attr
.access
= ACCESS_PRIVATE
;
2811 c
->ts
.type
= BT_VOID
;
2812 c
->initializer
= gfc_get_null_expr (NULL
);
2814 /* Add component _copy. */
2815 if (!gfc_add_component (vtype
, "_copy", &c
))
2817 c
->attr
.proc_pointer
= 1;
2818 c
->attr
.access
= ACCESS_PRIVATE
;
2819 c
->tb
= XCNEW (gfc_typebound_proc
);
2823 if (ts
->type
!= BT_CHARACTER
)
2824 name
= xasprintf ("__copy_%s", tname
);
2827 /* __copy is always the same for characters.
2828 Check to see if copy function already exists. */
2829 name
= xasprintf ("__copy_character_%d", ts
->kind
);
2830 contained
= ns
->contained
;
2831 for (; contained
; contained
= contained
->sibling
)
2832 if (contained
->proc_name
2833 && strcmp (name
, contained
->proc_name
->name
) == 0)
2835 copy
= contained
->proc_name
;
2840 /* Set up namespace. */
2841 sub_ns
= gfc_get_namespace (ns
, 0);
2842 sub_ns
->sibling
= ns
->contained
;
2843 ns
->contained
= sub_ns
;
2844 sub_ns
->resolved
= 1;
2845 /* Set up procedure symbol. */
2846 gfc_get_symbol (name
, sub_ns
, ©
);
2847 sub_ns
->proc_name
= copy
;
2848 copy
->attr
.flavor
= FL_PROCEDURE
;
2849 copy
->attr
.subroutine
= 1;
2850 copy
->attr
.pure
= 1;
2851 copy
->attr
.if_source
= IFSRC_DECL
;
2852 /* This is elemental so that arrays are automatically
2853 treated correctly by the scalarizer. */
2854 copy
->attr
.elemental
= 1;
2855 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2856 copy
->module
= ns
->proc_name
->name
;
2857 gfc_set_sym_referenced (copy
);
2858 /* Set up formal arguments. */
2859 gfc_get_symbol ("src", sub_ns
, &src
);
2860 src
->ts
.type
= ts
->type
;
2861 src
->ts
.kind
= ts
->kind
;
2862 src
->attr
.flavor
= FL_VARIABLE
;
2863 src
->attr
.dummy
= 1;
2864 src
->attr
.intent
= INTENT_IN
;
2865 gfc_set_sym_referenced (src
);
2866 copy
->formal
= gfc_get_formal_arglist ();
2867 copy
->formal
->sym
= src
;
2868 gfc_get_symbol ("dst", sub_ns
, &dst
);
2869 dst
->ts
.type
= ts
->type
;
2870 dst
->ts
.kind
= ts
->kind
;
2871 dst
->attr
.flavor
= FL_VARIABLE
;
2872 dst
->attr
.dummy
= 1;
2873 dst
->attr
.intent
= INTENT_INOUT
;
2874 gfc_set_sym_referenced (dst
);
2875 copy
->formal
->next
= gfc_get_formal_arglist ();
2876 copy
->formal
->next
->sym
= dst
;
2878 sub_ns
->code
= gfc_get_code (EXEC_INIT_ASSIGN
);
2879 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
2880 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
2882 /* Set initializer. */
2883 c
->initializer
= gfc_lval_expr_from_sym (copy
);
2884 c
->ts
.interface
= copy
;
2886 /* Add component _final. */
2887 if (!gfc_add_component (vtype
, "_final", &c
))
2889 c
->attr
.proc_pointer
= 1;
2890 c
->attr
.access
= ACCESS_PRIVATE
;
2891 c
->attr
.artificial
= 1;
2892 c
->tb
= XCNEW (gfc_typebound_proc
);
2894 c
->initializer
= gfc_get_null_expr (NULL
);
2896 vtab
->ts
.u
.derived
= vtype
;
2897 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
2905 /* It is unexpected to have some symbols added at resolution or code
2906 generation time. We commit the changes in order to keep a clean state. */
2909 gfc_commit_symbol (vtab
);
2911 gfc_commit_symbol (vtype
);
2913 gfc_commit_symbol (copy
);
2915 gfc_commit_symbol (src
);
2917 gfc_commit_symbol (dst
);
2920 gfc_undo_symbols ();
2926 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2929 gfc_find_vtab (gfc_typespec
*ts
)
2936 return gfc_find_derived_vtab (ts
->u
.derived
);
2938 if (ts
->u
.derived
->attr
.is_class
2939 && ts
->u
.derived
->components
2940 && ts
->u
.derived
->components
->ts
.u
.derived
)
2941 return gfc_find_derived_vtab (ts
->u
.derived
->components
->ts
.u
.derived
);
2945 return find_intrinsic_vtab (ts
);
2950 /* General worker function to find either a type-bound procedure or a
2951 type-bound user operator. */
2954 find_typebound_proc_uop (gfc_symbol
* derived
, bool* t
,
2955 const char* name
, bool noaccess
, bool uop
,
2961 /* Set default to failure. */
2965 if (derived
->f2k_derived
)
2966 /* Set correct symbol-root. */
2967 root
= (uop
? derived
->f2k_derived
->tb_uop_root
2968 : derived
->f2k_derived
->tb_sym_root
);
2972 /* Try to find it in the current type's namespace. */
2973 res
= gfc_find_symtree (root
, name
);
2974 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
2980 if (!noaccess
&& derived
->attr
.use_assoc
2981 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
2984 gfc_error ("%qs of %qs is PRIVATE at %L",
2985 name
, derived
->name
, where
);
2993 /* Otherwise, recurse on parent type if derived is an extension. */
2994 if (derived
->attr
.extension
)
2996 gfc_symbol
* super_type
;
2997 super_type
= gfc_get_derived_super_type (derived
);
2998 gcc_assert (super_type
);
3000 return find_typebound_proc_uop (super_type
, t
, name
,
3001 noaccess
, uop
, where
);
3004 /* Nothing found. */
3009 /* Find a type-bound procedure or user operator by name for a derived-type
3010 (looking recursively through the super-types). */
3013 gfc_find_typebound_proc (gfc_symbol
* derived
, bool* t
,
3014 const char* name
, bool noaccess
, locus
* where
)
3016 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
3020 gfc_find_typebound_user_op (gfc_symbol
* derived
, bool* t
,
3021 const char* name
, bool noaccess
, locus
* where
)
3023 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
3027 /* Find a type-bound intrinsic operator looking recursively through the
3028 super-type hierarchy. */
3031 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, bool* t
,
3032 gfc_intrinsic_op op
, bool noaccess
,
3035 gfc_typebound_proc
* res
;
3037 /* Set default to failure. */
3041 /* Try to find it in the current type's namespace. */
3042 if (derived
->f2k_derived
)
3043 res
= derived
->f2k_derived
->tb_op
[op
];
3048 if (res
&& !res
->error
)
3054 if (!noaccess
&& derived
->attr
.use_assoc
3055 && res
->access
== ACCESS_PRIVATE
)
3058 gfc_error ("%qs of %qs is PRIVATE at %L",
3059 gfc_op2string (op
), derived
->name
, where
);
3067 /* Otherwise, recurse on parent type if derived is an extension. */
3068 if (derived
->attr
.extension
)
3070 gfc_symbol
* super_type
;
3071 super_type
= gfc_get_derived_super_type (derived
);
3072 gcc_assert (super_type
);
3074 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
3078 /* Nothing found. */
3083 /* Get a typebound-procedure symtree or create and insert it if not yet
3084 present. This is like a very simplified version of gfc_get_sym_tree for
3085 tbp-symtrees rather than regular ones. */
3088 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
3090 gfc_symtree
*result
= gfc_find_symtree (*root
, name
);
3091 return result
? result
: gfc_new_symtree (root
, name
);